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 Name
-corePrelude = Module (Just ("Prelude", [])) $
+-- corePrelude = Module (Just ("Prelude", [])) $
-    -- non-primitive defs
+--     -- non-primitive defs
-    [coreProg|
+--     [coreProg|
-        id x = x;
+--         id x = x;
-        k x y = x;
+--         k x y = x;
-        k1 x y = y;
+--         k1 x y = y;
-        s f g x = f x (g x);
+--         s f g x = f x (g x);
-        compose f g x = f (g x);
+--         compose f g x = f (g x);
-        twice f x = f (f x);
+--         twice f x = f (f x);
-        fst p = casePair# p k;
+--         fst p = casePair# p k;
-        snd p = casePair# p k1;
+--         snd p = casePair# p k1;
-        head l = caseList# l abort# k;
+--         head l = caseList# l abort# k;
-        tail l = caseList# l abort# k1;
+--         tail l = caseList# l abort# k1;
-        _length_cc x xs = (+#) 1 (length xs);
+--         _length_cc x xs = (+#) 1 (length xs);
-        length l = caseList# l 0 length_cc;
+--         length l = caseList# l 0 length_cc;
-    |]
+--     |]
-    <>
+--     <>
-    -- primitive constructors need some specialised wiring:
+--     -- primitive constructors need some specialised wiring:
-    Program
+--     Program
-        [ ScDef "False" [] $ Con 0 0
+--         [ ScDef "False" [] $ Con 0 0
-        , ScDef "True" [] $ Con 1 0
+--         , ScDef "True" [] $ Con 1 0
-        , ScDef "MkPair" [] $ Con 0 2
+--         , ScDef "MkPair" [] $ Con 0 2
-        , ScDef "Nil" [] $ Con 1 0
+--         , ScDef "Nil" [] $ Con 1 0
-        , ScDef "Cons" [] $ Con 2 2
+--         , ScDef "Cons" [] $ Con 2 2
-        ]
+--         ]
+
+--}
 

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

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
+
 }
 

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]
+makeLenses ''Program
-programScDefs = lens coerce (const coerce)
+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
+instance (Hashable b) => Semigroup (Program b) where
-    mempty = Program []
+    (<>) = undefined
+
+instance (Hashable b) => Monoid (Program b) where
+    mempty = Program mempty mempty
 
 ----------------------------------------------------------------------------------
 

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 b -> Program b -> Program b
-insertModule (Module _ m) p = p <> m
+-- insertModule (Module _ p) = programScDefs %~ (<>m)
 
 extractProgram :: Module b -> Program b
 extractProgram (Module _ p) = p

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

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
+resultOfExpr e = resultOf $
+    mempty & programScDefs .~
                 [ ScDef "main" [] e
                 ]