msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

parse type sigs; program type sigs

Browse Source
This commit is contained in:
crumbtoo
2023-12-20 13:41:43 -07:00
parent 6f522d34ff
commit 414312cf98
7 changed files with 88 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

63
src/Core/Examples.hs
View File

@@ -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
-- ]
--}

2
src/Core/Lex.x
View File

@@ -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

24
src/Core/Parse.y
View File

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

21
src/Core/Syntax.hs
View File

@@ -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
----------------------------------------------------------------------------------

7
src/Core/Utils.hs
View File

@@ -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

2
src/Core2Core.hs
View File

@@ -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

6
src/GM.hs
View File

@@ -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
]