diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 430a94f..cb1823e 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -15,7 +15,14 @@ import Core.Syntax import Core.TH ---------------------------------------------------------------------------------- --- TODO: my shitty lexer isn't inserting semicolons +-- +fac3 = undefined +sumList = undefined +constDivZero = undefined +idCase = undefined +--} + +{-- letrecExample :: Program' letrecExample = [coreProg| @@ -191,30 +198,32 @@ idCase = [coreProg| }) |] -corePrelude :: Module Name -corePrelude = Module (Just ("Prelude", [])) $ - -- non-primitive defs - [coreProg| - id x = x; - k x y = x; - k1 x y = y; - s f g x = f x (g x); - compose f g x = f (g x); - twice f x = f (f x); - fst p = casePair# p k; - snd p = casePair# p k1; - head l = caseList# l abort# k; - tail l = caseList# l abort# k1; - _length_cc x xs = (+#) 1 (length xs); - length l = caseList# l 0 length_cc; - |] - <> - -- primitive constructors need some specialised wiring: - Program - [ ScDef "False" [] $ Con 0 0 - , ScDef "True" [] $ Con 1 0 - , ScDef "MkPair" [] $ Con 0 2 - , ScDef "Nil" [] $ Con 1 0 - , ScDef "Cons" [] $ Con 2 2 - ] +-- corePrelude :: Module Name +-- corePrelude = Module (Just ("Prelude", [])) $ +-- -- non-primitive defs +-- [coreProg| +-- id x = x; +-- k x y = x; +-- k1 x y = y; +-- s f g x = f x (g x); +-- compose f g x = f (g x); +-- twice f x = f (f x); +-- fst p = casePair# p k; +-- snd p = casePair# p k1; +-- head l = caseList# l abort# k; +-- tail l = caseList# l abort# k1; +-- _length_cc x xs = (+#) 1 (length xs); +-- length l = caseList# l 0 length_cc; +-- |] +-- <> +-- -- primitive constructors need some specialised wiring: +-- Program +-- [ ScDef "False" [] $ Con 0 0 +-- , ScDef "True" [] $ Con 1 0 +-- , ScDef "MkPair" [] $ Con 0 2 +-- , ScDef "Nil" [] $ Con 1 0 +-- , ScDef "Cons" [] $ Con 2 2 +-- ] + +--} diff --git a/src/Core/Lex.x b/src/Core/Lex.x index b666d69..55946e8 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -68,6 +68,7 @@ rlp :- "{" { constTok TokenLBrace } "}" { constTok TokenRBrace } ";" { constTok TokenSemicolon } + "::" { constTok TokenHasType } "@" { constTok TokenTypeApp } "{-#" { constTok TokenLPragma `andBegin` pragma } @@ -134,6 +135,7 @@ data CoreToken = TokenLet | TokenLBrace | TokenRBrace | TokenSemicolon + | TokenHasType | TokenTypeApp | TokenLPragma | TokenRPragma diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 4dab15a..a2f8496 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -19,7 +19,10 @@ import Data.Foldable (foldl') import Core.Syntax import Core.Lex import Compiler.RLPC +import Lens.Micro import Data.Default.Class (def) +import Data.Hashable (Hashable) +import Data.HashMap.Strict qualified as H } %name parseCore Module @@ -55,6 +58,7 @@ import Data.Default.Class (def) '{-#' { Located _ _ _ TokenLPragma } '#-}' { Located _ _ _ TokenRPragma } ';' { Located _ _ _ TokenSemicolon } + '::' { Located _ _ _ TokenHasType } eof { Located _ _ _ TokenEOF } %% @@ -71,7 +75,15 @@ StandaloneProgram :: { Program Name } StandaloneProgram : Program eof { $1 } Program :: { Program Name } -Program : ScDefs { Program $1 } +Program : ScTypeSig ';' Program { insTypeSig $1 $3 } + | ScTypeSig OptSemi { singletonTypeSig $1 } + +OptSemi :: { () } +OptSemi : ';' { () } + | {- epsilon -} { () } + +ScTypeSig :: { (Name, Type) } +ScTypeSig : Var '::' Type { ($1,$3) } ScDefs :: { [ScDef Name] } ScDefs : ScDef ';' ScDefs { $1 : $3 } @@ -82,6 +94,9 @@ ScDefs : ScDef ';' ScDefs { $1 : $3 } ScDef :: { ScDef Name } ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 } +Type :: { Type } +Type : Var { TyInt } + ParList :: { [Name] } ParList : Var ParList { $1 : $2 } | {- epsilon -} { [] } @@ -190,5 +205,12 @@ exprPragma _ = addFatal err astPragma :: [String] -> RLPC SrcError (Expr Name) astPragma = pure . read . unwords +insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b +insTypeSig ts = programTypeSigs %~ uncurry H.insert ts + +singletonTypeSig :: (Hashable b) => (b, Type) -> Program b +singletonTypeSig ts = mempty + & programTypeSigs .~ uncurry H.singleton ts + } diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 24d13b9..8f20599 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -4,6 +4,7 @@ Description : Core ASTs and the like -} {-# LANGUAGE PatternSynonyms, OverloadedStrings #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} module Core.Syntax ( Expr(..) , Type(..) @@ -24,6 +25,7 @@ module Core.Syntax , Program(..) , Program' , programScDefs + , programTypeSigs , Expr' , ScDef' , Alter' @@ -39,8 +41,11 @@ import GHC.Generics import Data.List (intersperse) import Data.Function ((&)) import Data.String +import Data.HashMap.Strict qualified as H +import Data.Hashable -- Lift instances for the Core quasiquoters import Language.Haskell.TH.Syntax (Lift) +import Lens.Micro.TH (makeLenses) import Lens.Micro ---------------------------------------------------------------------------------- @@ -113,11 +118,14 @@ data ScDef b = ScDef b [b] (Expr b) data Module b = Module (Maybe (Name, [Name])) (Program b) deriving (Show, Lift) -newtype Program b = Program [ScDef b] +data Program b = Program + { _programScDefs :: [ScDef b] + , _programTypeSigs :: H.HashMap b Type + } deriving (Show, Lift) -programScDefs :: Lens' (Program b) [ScDef b] -programScDefs = lens coerce (const coerce) +makeLenses ''Program +pure [] type Program' = Program Name type Expr' = Expr Name @@ -134,8 +142,11 @@ instance IsString Type where instance Semigroup (Program b) where (<>) = coerce $ (<>) @[ScDef b] -instance Monoid (Program b) where - mempty = Program [] +instance (Hashable b) => Semigroup (Program b) where + (<>) = undefined + +instance (Hashable b) => Monoid (Program b) where + mempty = Program mempty mempty ---------------------------------------------------------------------------------- diff --git a/src/Core/Utils.hs b/src/Core/Utils.hs index 892a7e3..1a47785 100644 --- a/src/Core/Utils.hs +++ b/src/Core/Utils.hs @@ -7,7 +7,7 @@ module Core.Utils ( bindersOf , rhssOf , isAtomic - , insertModule + -- , insertModule , extractProgram , freeVariables , ExprF(..) @@ -19,6 +19,7 @@ import Data.Functor.Foldable import Data.Set (Set) import Data.Set qualified as S import Core.Syntax +import Lens.Micro import GHC.Exts (IsList(..)) ---------------------------------------------------------------------------------- @@ -38,8 +39,8 @@ isAtomic _ = False ---------------------------------------------------------------------------------- -- TODO: export list awareness -insertModule :: Module b -> Program b -> Program b -insertModule (Module _ m) p = p <> m +-- insertModule :: Module b -> Program b -> Program b +-- insertModule (Module _ p) = programScDefs %~ (<>m) extractProgram :: Module b -> Program b extractProgram (Module _ p) = p diff --git a/src/Core2Core.hs b/src/Core2Core.hs index 7aa9dc6..aca3552 100644 --- a/src/Core2Core.hs +++ b/src/Core2Core.hs @@ -27,7 +27,7 @@ core2core :: Program' -> Program' core2core p = undefined gmPrep :: Program' -> Program' -gmPrep p = p' <> Program caseScs +gmPrep p = p' & programScDefs %~ (<>caseScs) where rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z) rhss = programScDefs . each . _rhs diff --git a/src/GM.hs b/src/GM.hs index 00f125f..7efd0cd 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid (Endo(..)) import Data.Tuple (swap) import Lens.Micro +import Lens.Micro.Extras (view) import Lens.Micro.TH import Text.Printf import Text.PrettyPrint hiding ((<>)) @@ -582,7 +583,7 @@ compiledPrims = binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind]) buildInitialHeap :: Program' -> (GmHeap, Env) -buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs +buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compiledScs where compiledScs = fmap compileSc ss <> compiledPrims @@ -975,7 +976,8 @@ resultOf p = do h = st ^. gmHeap resultOfExpr :: Expr' -> Maybe Node -resultOfExpr e = resultOf $ Program - [ ScDef "main" [] e - ] +resultOfExpr e = resultOf $ + mempty & programScDefs .~ + [ ScDef "main" [] e + ]