Add helper for constructing builtins.

Author: ChickenProp

package.yaml

@@ -20,6 +20,7 @@ extra-source-files:
 description:         Please see the README on GitHub at <https://github.com/githubuser/haskenthetical#readme>
 
 default-extensions:
+- ApplicativeDo
 - DataKinds
 - DeriveGeneric
 - FlexibleContexts

src/Defaults.hs

@@ -39,15 +39,21 @@ hcdr :: Val -> Either Text Val
 hcdr (Tag "," [_, b]) = Right b
 hcdr _ = Left "cdr only accepts pairs"
 
-heither :: Val -> Either Text Val
-heither l = rbb "either.1" $ \r -> rbb "either.2" $ \case
-  Tag "Left" [v] -> call l v
-  Tag "Right" [v] -> call r v
-  _ -> Left "final argument of either must be an Either"
+heither :: Val
+heither = mkBuiltinUnsafe $ do
+  l <- getArg "either"
+  r <- getArg "either.1"
+  e <- getArg "either.2"
+  pure $ case e of
+    Tag "Left" [v] -> call l v
+    Tag "Right" [v] -> call r v
+    _ -> Left "final argument of either must be an Either"
 
 hif0 :: Val -> Either Text Val
-hif0 (Float v) = rbb "if0.1" $ \then_ -> rbb "if0.2" $ \else_ ->
-  if v == 0 then Right then_ else Right else_
+hif0 (Float v) = mkBuiltin $ do
+  then_ <- getArg "if0.1"
+  else_ <- getArg "if0.2"
+  pure $ Right $ if v == 0 then then_ else else_
 hif0 _ = Left "first arg to if0 must be a Float"
 
 defaultVarEnv :: Map Name (PType Tc, Val)
@@ -65,7 +71,7 @@ defaultVarEnv = fmap (\(x, y) -> (y, x)) $ Map.fromList
       ~~ bb "Right" (Right . Tag "Right" . (: []))
       ~~ Forall [a', b'] (b +-> (a +:+ b))
   , "either"
-      ~~ bb "either" heither
+      ~~ heither
       ~~ Forall [a', b', c'] ((a +-> c) +-> (b +-> c) +-> (a +:+ b) +-> c)
   , "if0" ~~ bb "if0" hif0  ~~ Forall [a'] (tFloat +-> a +-> a +-> a)
   ]

src/Env.hs

@@ -96,7 +96,7 @@ declareTypeConstructors (TypeDecl' { tdName, tdVars, tdConstructors }) env = do
   newVars = foldM
     (\vars (conName, argNames) -> do
       ty <- conType argNames
-      val <- conVal conName argNames
+      let val = conVal conName argNames
       insertUnique (CEMultiDeclareConstructor conName) conName (ty, val) vars
     )
     (feVars env) tdConstructors
@@ -118,13 +118,14 @@ declareTypeConstructors (TypeDecl' { tdName, tdVars, tdConstructors }) env = do
 
     return $ Forall allVars $ foldr (+->) finalType types
 
-  conVal :: Name -> [MType Ps] -> Either CompileError Val
-  conVal conName ts = return $ go [] 0 (length ts)
+  conVal :: Name -> [MType Ps] -> Val
+  conVal conName ts = go [] 0 (length ts)
    where
     go :: [Val] -> Int -> Int -> Val
     go acc _ 0 = Tag conName acc
-    go acc d n = Builtin $ Builtin' (mkName d) $ \v ->
-      Right $ go (acc ++ [v]) (d + 1) (n - 1)
+    go acc d n = mkBuiltinUnsafe $ do
+      v <- getArg (mkName d)
+      pure $ Right $ go (acc ++ [v]) (d + 1) (n - 1)
 
     mkName 0 = conName
     mkName n = conName <> "." <> Name (tshow n)

src/Syntax.hs

@@ -20,6 +20,8 @@ module Syntax
   , extractType
   , mkTyped
   , rmType
+
+  , DoBuiltin(..), getArg, mkBuiltin, mkBuiltinUnsafe
   ) where
 
 import Prelude.Extra
@@ -62,6 +64,34 @@ instance Show Builtin where
 instance Eq Builtin where
   Builtin' n1 _ == Builtin' n2 _ = n1 == n2
 
+-- | A helper type to let us construct `Builtin` with do notation. Use with
+-- `getArg` and `mkBuiltin`.
+--
+-- There's no Monad instance for this, and there can't be. Needs ApplicativeDo.
+-- Some other datatype might let us achieve the same goal with more generality.
+data DoBuiltin a = DoBuiltin [Name] ([Val] -> a)
+
+instance Functor DoBuiltin where
+  fmap f (DoBuiltin ns g) = DoBuiltin ns (f . g)
+
+instance Applicative DoBuiltin where
+  pure a = DoBuiltin [] (const a)
+  (DoBuiltin ns1 f) <*> (DoBuiltin ns2 g) = DoBuiltin (ns1 ++ ns2) $ \vals ->
+    let fVals = take (length ns1) vals
+        gVals = drop (length ns1) vals
+    in (f fVals) (g gVals)
+
+getArg :: Name -> DoBuiltin Val
+getArg n = DoBuiltin [n] head
+
+mkBuiltin :: DoBuiltin (Either Text Val) -> Either Text Val
+mkBuiltin (DoBuiltin [] f) = f []
+mkBuiltin (DoBuiltin (n1:ns) f) = Right $ Builtin $ Builtin' n1 $ \v ->
+  mkBuiltin $ DoBuiltin ns (\vs -> f (v : vs))
+
+mkBuiltinUnsafe :: DoBuiltin (Either Text Val) -> Val
+mkBuiltinUnsafe = either (error "Bad DoBuiltin") id . mkBuiltin
+
 newtype Env = Env { unEnv :: Map Name Val }
   deriving (Eq, Show)