src/Core/Parse.y

@@ -3,7 +3,7 @@
 Module : Core.Parse
 Description : Parser for the Core language
 -}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 module Core.Parse
     ( parseCore
     , parseCoreExpr
@@ -23,7 +23,9 @@ import Compiler.RLPC
 import Lens.Micro
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
+import Data.List.Extra
 import Data.Text.IO         qualified as TIO
+import Data.Text            (Text)
 import Data.Text            qualified as T
 import Data.HashMap.Strict  qualified as H
 }
@@ -83,6 +85,15 @@ Program         : ScTypeSig ';' Program         { insTypeSig $1 $3 }
                 | ScTypeSig OptSemi             { singletonTypeSig $1 }
                 | ScDef     ';' Program         { insScDef $1 $3 }
                 | ScDef     OptSemi             { singletonScDef $1 }
+                | TLPragma  ';' Program         {% doTLPragma $1 $3 }
+                | TLPragma  OptSemi             {% doTLPragma $1 mempty }
+
+TLPragma        :: { Pragma }
+                : '{-#' Words '#-}'             { Pragma $2 }
+
+Words           :: { [Text] }
+                : Words word                    { $1 `snoc` $2 }
+                | word                          { [$1] }
 
 OptSemi         :: { () }
 OptSemi         : ';'                           { () }
@@ -150,22 +161,15 @@ Alters          : Alter ';' Alters              { $1 : $3 }
                 | Alter                         { [$1] }
 
 Alter           :: { Alter Name }
-Alter           : alttag ParList '->' Expr      { Alter (AltTag $1) $2 $4 }
+Alter           : alttag ParList '->' Expr      { Alter (AltTag  $1) $2 $4 }
+                | Con    ParList '->' Expr      { Alter (AltData $1) $2 $4 }
 
 Expr1           :: { Expr Name }
 Expr1           : litint                        { Lit $ IntL $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
-                | ExprPragma                    { $1 }
                 | '(' Expr ')'                  { $2 }
 
-ExprPragma      :: { Expr Name }
-ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
-
-Words           :: { [String] }
-Words           : word Words                    { T.unpack $1 : $2 }
-                | word                          { [T.unpack $1] }
-
 PackCon         :: { Expr Name }
 PackCon         : pack '{' litint litint '}'    { Con $3 $4 }
 
@@ -230,5 +234,17 @@ happyBind m k = m >>= k
 happyPure :: a -> RLPC a
 happyPure a = pure a
 
+doTLPragma :: Pragma -> Program' -> RLPC Program'
+-- TODO: warn unrecognised pragma
+doTLPragma (Pragma []) p = pure p
+
+doTLPragma (Pragma pr) p = case pr of
+    -- TODO: warn on overwrite
+    ["PackData", n, readt -> t, readt -> a] ->
+        pure $ p & programDataTags . at n ?~ (t,a)
+
+readt :: (Read a) => Text -> a
+readt = read . T.unpack
+
 }
 

src/Core/Syntax.hs

@@ -25,9 +25,11 @@ module Core.Syntax
     , Module(..)
     , Program(..)
     , Program'
+    , Pragma(..)
     , unliftScDef
     , programScDefs
     , programTypeSigs
+    , programDataTags
     , Expr'
     , ScDef'
     , Alter'
@@ -102,6 +104,8 @@ data Alter b = Alter AltCon [b] (Expr b)
 
 deriving instance (Eq b) => Eq (Alter b)
 
+newtype Pragma = Pragma [T.Text]
+
 data Rec = Rec
          | NonRec
          deriving (Show, Read, Eq, Lift)

src/Core2Core.hs

@@ -15,7 +15,7 @@ import Data.Set                 (Set)
 import Data.Set                 qualified as S
 import Data.List
 import Control.Monad.Writer
-import Control.Monad.State
+import Control.Monad.State.Lazy
 import Control.Arrow            ((>>>))
 import Data.Text                qualified as T
 import Numeric                  (showHex)
@@ -28,19 +28,16 @@ core2core :: Program' -> Program'
 core2core p = undefined
 
 gmPrep :: Program' -> Program'
-gmPrep p = p' & programScDefs %~ (<>caseScs)
+gmPrep p = p & traverseOf rhss (floatNonStrictCases globals)
+             & runFloater
+             & \ (me,caseScs) -> me & programScDefs %~ (<>caseScs)
     where
-        rhss :: Applicative f => (Expr z -> f (Expr z)) -> Program z -> f (Program z)
+        rhss :: Traversal' (Program z) (Expr z)
         rhss = programScDefs . each . _rhs
+
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
-        -- i kinda don't like that we're calling floatNonStrictCases twice tbh
-        p'      = p & rhss %~ fst . runFloater . floatNonStrictCases globals
-        caseScs = (p ^.. rhss)
-              <&> snd . runFloater . floatNonStrictCases globals
-                & mconcat
-
 -- | Auxilary type used in @floatNonSrictCases@
 type Floater = StateT [Name] (Writer [ScDef'])
 

src/GM.hs

@@ -661,7 +661,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
         compileC _ (Con t n) = [PushConstr t n]
 
         compileC _ (Case _ _) =
-            error "case expressions may not appear in non-strict contexts :/"
+            error "GM compiler found a non-strict case expression, which should\
+                  \ have been floated by Core2Core.gmPrep. This is bad!"
 
         compileC _ _ = error "yet to be implemented!"