poly_constraints: update build

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

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

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

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

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"

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