diff options
| -rw-r--r-- | src/Haskell/AST.hs | 3 | ||||
| -rw-r--r-- | src/Haskell/Parser.hs | 3 | ||||
| -rw-r--r-- | src/Haskell/Rewrite.hs | 5 |
3 files changed, 9 insertions, 2 deletions
diff --git a/src/Haskell/AST.hs b/src/Haskell/AST.hs index f8b5c72..072fd97 100644 --- a/src/Haskell/AST.hs +++ b/src/Haskell/AST.hs @@ -22,6 +22,7 @@ data Def = Def Name Expr data Expr = App Expr [Expr] | Ref Name + | Con Name | Num Integer | Tup [Expr] | Lam [Name] Expr @@ -71,6 +72,7 @@ instance Pretty Def where instance Pretty Expr where pretty (App e as) = Bracket "(" ")" "" (map pretty (e:as)) pretty (Ref n) = Leaf n + pretty (Con n) = Leaf n pretty (Num n) = Leaf (show n) pretty (Tup es) = Bracket "(" ")" "," (map pretty es) pretty (Lam as e) = Bracket "(" ")" "" [Node ("\\" ++ intercalate " " as ++ " ->") [pretty e]] @@ -124,6 +126,7 @@ instance AllRefs Def where instance AllRefs Expr where allRefs (App e es) = nub $ concatMap allRefs (e : es) allRefs (Ref n) = [n] + allVars (Con _) = [] allRefs (Num _) = [] allRefs (Tup es) = nub $ concatMap allRefs es allRefs (Lam ns e) = allRefs e \\ ns diff --git a/src/Haskell/Parser.hs b/src/Haskell/Parser.hs index bd10705..9ebf2af 100644 --- a/src/Haskell/Parser.hs +++ b/src/Haskell/Parser.hs @@ -36,6 +36,7 @@ pExpr = pLam <|> pCase <|> pApp where pSimpleExpr = choice [Num <$> pNum ,Ref <$> pVariable + ,Con <$> pNameT ,parens (pExpr `sepBy` symbolO ",") >>= \case [ex] -> return ex exs -> return $ Tup exs] @@ -82,7 +83,7 @@ pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive where pPositive = read <$> many1 digit <* aheadW pVariable :: Parser Name -pVariable = pName <|> try (parens pOperator) +pVariable = pNameV <|> try (parens pOperator) pName :: Parser Name pName = notReserved $ liftM2 (:) (satisfy isAlpha) pNameRest diff --git a/src/Haskell/Rewrite.hs b/src/Haskell/Rewrite.hs index 7eaadea..498ccae 100644 --- a/src/Haskell/Rewrite.hs +++ b/src/Haskell/Rewrite.hs @@ -79,8 +79,10 @@ unify :: Pat -> Expr -> Maybe (Map.Map Name Expr) unify PatAny _ = Just Map.empty unify (PatVar n) e = Just (Map.singleton n e) unify (PatCon n ps) (App n' es) - | n' == Ref n, length ps == length es = + | n' == Con n, length ps == length es = foldM (\m (p, e) -> unify p e >>= reconcile m) Map.empty (zip ps es) +unify (PatCon n []) (Con n') + | n == n' = Just Map.empty unify (PatTup ps) (Tup es) | length ps == length es = foldM (\m (p, e) -> unify p e >>= reconcile m) Map.empty (zip ps es) @@ -101,6 +103,7 @@ normalise e = recurse id normalise e recurse :: (Pat -> Pat) -> (Expr -> Expr) -> Expr -> Expr recurse _ f (App e as) = App (f e) (map f as) recurse _ _ (Ref n) = Ref n +recurse _ _ (Con n) = Con n recurse _ _ (Num k) = Num k recurse _ f (Tup es) = Tup (map f es) recurse _ f (Lam ns e) = Lam ns (f e) |