Skip to content
Permalink
Browse files
Add helper for constructing builtins.
  • Loading branch information
ChickenProp committed Feb 26, 2020
1 parent 835269c commit e1ee65de57090f2f8393fd2124f10d8a5ca21413
Showing 4 changed files with 51 additions and 13 deletions.
@@ -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
@@ -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)
]
@@ -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)
@@ -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)

0 comments on commit e1ee65d

Please sign in to comment.