st/prog_synthesis
1
0
Fork 0
mirror of https://codeberg.org/ProgramSnail/prog_synthesis.git synced 2025-12-06 05:28:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

fix types, delete old escher

Browse source
This commit is contained in:
ProgramSnail 2025-11-05 12:43:53 +03:00
parent 753ca23cbc
commit f27f6c5559
2 changed files with 17 additions and 754 deletions
Download patch file Download diff file Expand all files Collapse all files

30
escher/TypeCheck.hs
View file

@ -19,8 +19,11 @@ isTree x | TreeT {} <- typeOf x = True
| otherwise = False
simpleUnify :: Type -> Type -> Maybe Type
simpleUnify t u | t == u = Just t
simpleUnify AnyT u = Just u
simpleUnify t AnyT = Just t
simpleUnify (ListT t) (ListT u) = ListT <$> simpleUnify t u
simpleUnify (TreeT t) (TreeT u) = TreeT <$> simpleUnify t u
simpleUnify _ _ = Nothing
checkType :: TypeConf -> Expr -> Maybe Type
@ -34,7 +37,7 @@ checkType conf (NotE e) = do BoolT <- checkType conf e
return BoolT
checkType conf (left :=: right) = do leftT <- checkType conf left
rightT <- checkType conf right
guard $ leftT == rightT
eqT <- simpleUnify leftT rightT
return BoolT
checkType conf (Leq0 e) = do IntT <- checkType conf e
return BoolT
@ -63,12 +66,12 @@ checkType conf (HeadE e) = do ListT t <- checkType conf e
return t
checkType conf (left :++: right) = do ListT t <- checkType conf left
ListT u <- checkType conf right
w <- simpleUnify t u
return $ ListT w
u' <- simpleUnify t u
return $ ListT u'
checkType conf (left ::: right) = do t <- checkType conf left
ListT u <- checkType conf right
w <- simpleUnify t u
return $ ListT w
u' <- simpleUnify t u
return $ ListT u'
checkType conf EmptyListE = return $ ListT AnyT -- NOTE: ListT AnyT - type of generic empty list
checkType conf (IsLeafE e) = do TreeT _ <- checkType conf e
return BoolT
@ -80,21 +83,22 @@ checkType conf (TreeRightE e) = do TreeT t <- checkType conf e
return $ TreeT t
checkType conf (CreateNodeE {nodeLeft, nodeRoot, nodeRight}) = do TreeT t <- checkType conf nodeLeft
u <- checkType conf nodeRoot
guard $ t == u
u' <- simpleUnify t u
TreeT w <- checkType conf nodeRight
guard $ t == w
return $ TreeT t
w' <- simpleUnify u' w
return $ TreeT w'
checkType conf (CreateLeafE e) = do t <- checkType conf e
return $ TreeT t
checkType conf (IfE {ifCond, ifDoThen, ifDoElse}) = do BoolT <- checkType conf ifCond
leftT <- checkType conf ifDoThen
rightT <- checkType conf ifDoElse
guard $ leftT == rightT
return leftT
simpleUnify leftT rightT
checkType conf (SelfE es) = do let ts = typeConfInput conf
guard $ length ts == length es
guard $ and $ zipWith (\t e -> checkType conf e == Just t) ts es
return $ typeConfOutput conf
if length ts /= length es then error $ "Recursive call: not enough args, " ++
show es ++ " provided while "++
show ts ++ " are required" else do
guard $ and $ zipWith (\t e -> checkType conf e == Just t) ts es
return $ typeConfOutput conf
checkType conf (InputE i) = Just $ typeConfInput conf !! i
checkType _ Hole = Nothing
-- checkType _ _ = Nothing