diff --git a/chapter7/poly_constraints/poly.cabal b/chapter7/poly_constraints/poly.cabal index ddd193b..29401b6 100644 --- a/chapter7/poly_constraints/poly.cabal +++ b/chapter7/poly_constraints/poly.cabal @@ -10,14 +10,14 @@ cabal-version: >=1.10 executable poly build-depends: - base >= 4.6 && <4.9 - , pretty >= 1.1 && <1.2 - , parsec >= 3.1 && <3.2 - , text >= 1.2 && <1.3 - , containers >= 0.5 && <0.6 - , mtl >= 2.2 && <2.3 - , transformers >= 0.4.2 && <0.5 - , repline >= 0.1.2.0 + base + , pretty + , parsec + , text + , containers + , mtl + , transformers + , repline other-modules: Env diff --git a/chapter7/poly_constraints/src/Env.hs b/chapter7/poly_constraints/src/Env.hs index 3be6c8f..409d2e2 100644 --- a/chapter7/poly_constraints/src/Env.hs +++ b/chapter7/poly_constraints/src/Env.hs @@ -64,6 +64,8 @@ fromList xs = TypeEnv (Map.fromList xs) toList :: Env -> [(Name, Scheme)] toList (TypeEnv env) = Map.toList env +instance Semigroup Env where + (<>) = merge + instance Monoid Env where mempty = empty - mappend = merge diff --git a/chapter7/poly_constraints/src/Eval.hs b/chapter7/poly_constraints/src/Eval.hs index 99e700e..8dcea20 100644 --- a/chapter7/poly_constraints/src/Eval.hs +++ b/chapter7/poly_constraints/src/Eval.hs @@ -31,15 +31,23 @@ eval env expr = case expr of return v Op op a b -> do - VInt a' <- eval env a - VInt b' <- eval env b + let unwrap comp = do v <- eval env comp + case v of + VInt x -> pure x + _ -> error "eval: type error: non-VInt" + a' <- unwrap a + b' <- unwrap b return $ (binop op) a' b' Lam x body -> return (VClosure x body env) App fun arg -> do - VClosure x body clo <- eval env fun + let unwrap comp = do v <- eval env comp + case v of + VClosure x y z -> pure (x, y, z) + _ -> error "eval: type error: non-VClosure" + (x, body, clo) <- unwrap fun argv <- eval env arg let nenv = Map.insert x argv clo eval nenv body @@ -50,7 +58,11 @@ eval env expr = case expr of eval nenv body If cond tr fl -> do - VBool br <- eval env cond + let unwrap comp = do v <- eval env comp + case v of + VBool x -> pure x + _ -> error "eval: type error: non-VBool" + br <- unwrap cond if br == True then eval env tr else eval env fl diff --git a/chapter7/poly_constraints/src/Infer.hs b/chapter7/poly_constraints/src/Infer.hs index 0d27259..0169b9e 100644 --- a/chapter7/poly_constraints/src/Infer.hs +++ b/chapter7/poly_constraints/src/Infer.hs @@ -51,7 +51,7 @@ type Unifier = (Subst, [Constraint]) type Solve a = ExceptT TypeError Identity a newtype Subst = Subst (Map.Map TVar Type) - deriving (Eq, Ord, Show, Monoid) + deriving (Eq, Ord, Show, Semigroup, Monoid) class Substitutable a where apply :: Subst -> a -> a diff --git a/chapter7/poly_constraints/src/Main.hs b/chapter7/poly_constraints/src/Main.hs index 47fd2e7..d41e9e4 100644 --- a/chapter7/poly_constraints/src/Main.hs +++ b/chapter7/poly_constraints/src/Main.hs @@ -91,22 +91,21 @@ cmd source = exec True (L.pack source) ------------------------------------------------------------------------------- -- :browse command -browse :: [String] -> Repl () +browse :: String -> Repl () browse _ = do st <- get liftIO $ mapM_ putStrLn $ ppenv (tyctx st) -- :load command -load :: [String] -> Repl () +load :: String -> Repl () load args = do - contents <- liftIO $ L.readFile (unwords args) + contents <- liftIO $ L.readFile args exec True contents -- :type command -typeof :: [String] -> Repl () -typeof args = do +typeof :: String -> Repl () +typeof arg = do st <- get - let arg = unwords args case Env.lookup arg (tyctx st) of Just val -> liftIO $ putStrLn $ ppsignature (arg, val) Nothing -> exec False (L.pack arg) @@ -134,8 +133,8 @@ comp n = do let defs = Map.keys ctx return $ filter (isPrefixOf n) (cmds ++ defs) -options :: [(String, [String] -> Repl ())] -options = [ +opts :: [(String, String -> Repl ())] +opts = [ ("load" , load) , ("browse" , browse) , ("quit" , quit) @@ -149,9 +148,19 @@ options = [ completer :: CompleterStyle (StateT IState IO) completer = Prefix (wordCompleter comp) defaultMatcher -shell :: Repl a -> IO () -shell pre = flip evalStateT initState - $ evalRepl "Poly> " cmd options completer pre +shell :: Repl () -> IO () +shell pre = flip evalStateT initState $ + evalReplOpts $ ReplOpts + { banner = const (pure "Poly> ") + , command = cmd + , options = opts + , prefix = Just ':' + , multilineCommand = Nothing + , tabComplete = completer + , initialiser = pre + , finaliser = pure Exit + } + ------------------------------------------------------------------------------- -- Toplevel @@ -162,6 +171,6 @@ main = do args <- getArgs case args of [] -> shell (return ()) - [fname] -> shell (load [fname]) - ["test", fname] -> shell (load [fname] >> browse [] >> quit ()) + [fname] -> shell (load fname) + ["test", fname] -> shell (load fname >> browse "" >> quit ()) _ -> putStrLn "invalid arguments" diff --git a/chapter7/poly_constraints/src/Pretty.hs b/chapter7/poly_constraints/src/Pretty.hs index 113a1cc..e34d677 100644 --- a/chapter7/poly_constraints/src/Pretty.hs +++ b/chapter7/poly_constraints/src/Pretty.hs @@ -18,7 +18,7 @@ import Type import Syntax import Infer -import Text.PrettyPrint +import Text.PrettyPrint hiding ((<>)) import qualified Data.Map as Map parensIf :: Bool -> Doc -> Doc @@ -45,7 +45,7 @@ instance Pretty Type where instance Pretty Scheme where ppr p (Forall [] t) = ppr p t - ppr p (Forall ts t) = text "forall" <+> hcat (punctuate space (map (ppr p) ts)) <> text "." <+> ppr p t + ppr p (Forall ts t) = text "forall" <+> (hcat (punctuate space (map (ppr p) ts)) <> (text "." <+> ppr p t)) instance Pretty Binop where ppr _ Add = text "+" @@ -56,15 +56,16 @@ instance Pretty Binop where instance Pretty Expr where ppr p (Var a) = ppr p a ppr p (App a b) = parensIf (p > 0) $ ppr (p+1) a <+> ppr p b - ppr p (Lam a b) = text "\\" <> ppr p a <+> text "->" <+> ppr p b - ppr p (Let a b c) = text "let" <> ppr p a <+> text "=" <+> ppr p b <+> text "in" <+> ppr p c + ppr p (Lam a b) = text "\\" <> (ppr p a <+> text "->" <+> ppr p b) + ppr p (Let a b c) = text "let" <> (ppr p a <+> text "=" <+> ppr p b <+> text "in" <+> ppr p c) ppr p (Lit a) = ppr p a ppr p (Op o a b) = parensIf (p>0) $ ppr p a <+> ppr p o <+> ppr p b ppr p (Fix a) = parensIf (p>0) $ text "fix" <> ppr p a ppr p (If a b c) = - text "if" <> ppr p a <+> - text "then" <+> ppr p b <+> - text "else" <+> ppr p c + text "if" <> + (ppr p a <+> + text "then" <+> ppr p b <+> + text "else" <+> ppr p c) instance Pretty Lit where ppr _ (LInt i) = integer i