oh boy (pack)

src/Core/Lex.x

@@ -42,6 +42,7 @@ $octit     = 0-7
 $hexit     = [0-9 A-F a-f]
 $namechar  = [$alpha $digit \' \#]
 $symchar   = [$symbol \:]
+$nonwhite  = $printable # $white
 $nl        = [\n\r]
 $white_no_nl = $white # $nl
 
@@ -68,6 +69,7 @@ rlp :-
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
     ","                     { constTok TokenComma }
+    "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 
     "let"                   { constTok TokenLet }
     "letrec"                { constTok TokenLetrec }
@@ -94,6 +96,19 @@ rlp :-
     \n                      { skip }
 }
 
+<pragma>
+{
+    "#-}"                   { constTok TokenRPragma `andBegin` 0 }
+    "{"                     { constTok TokenLBrace }
+    "}"                     { constTok TokenRBrace }
+    ";"                     { constTok TokenSemicolon }
+
+    $white                  { skip }
+    \n                      { skip }
+
+    $nonwhite+              { lexWith TokenWord }
+}
+
 {
 data Located a = Located Int Int Int a
     deriving Show
@@ -123,6 +138,9 @@ data CoreToken = TokenLet
                | TokenLBrace
                | TokenRBrace
                | TokenSemicolon
+               | TokenLPragma
+               | TokenRPragma
+               | TokenWord String
                | TokenEOF
                deriving Show
 
@@ -135,6 +153,7 @@ data SrcError = SrcError
 
 data SrcErrorType = SrcErrLexical String
                   | SrcErrParse
+                  | SrcErrUnknownPragma Name
                   deriving Show
 
 type Lexer = AlexInput -> Int -> Alex (Located CoreToken)

src/Core/Parse.y

@@ -44,6 +44,7 @@ import Data.Default.Class   (def)
       varsym          { Located _ _ _ (TokenVarSym $$) }
       conname         { Located _ _ _ (TokenConName $$) }
       consym          { Located _ _ _ (TokenConSym $$) }
+      word            { Located _ _ _ (TokenWord $$) }
       'λ'             { Located _ _ _ TokenLambda }
       '->'            { Located _ _ _ TokenArrow }
       '='             { Located _ _ _ TokenEquals }
@@ -51,6 +52,8 @@ import Data.Default.Class   (def)
       ')'             { Located _ _ _ TokenRParen }
       '{'             { Located _ _ _ TokenLBrace }
       '}'             { Located _ _ _ TokenRBrace }
+      '{-#'           { Located _ _ _ TokenLPragma }
+      '#-}'           { Located _ _ _ TokenRPragma }
       ';'             { Located _ _ _ TokenSemicolon }
       eof             { Located _ _ _ TokenEOF }
 
@@ -122,8 +125,16 @@ Expr1           :: { Expr }
 Expr1           : litint                        { IntE $1 }
                 | Id                            { Var $1 }
                 | PackCon                       { $1 }
+                | ExprPragma                    { $1 }
                 | '(' Expr ')'                  { $2 }
 
+ExprPragma      :: { Expr }
+ExprPragma      : '{-#' Words '#-}'      {% exprPragma $2 }
+
+Words           :: { [String] }
+Words           : word Words                    { $1 : $2 }
+                | word                          { [$1] }
+
 PackCon         :: { Expr }
 PackCon         : pack '{' litint ',' litint '}' { Con $3 $5 }
 
@@ -148,6 +159,7 @@ Con             : '(' consym ')'                    { $2 }
                 | conname                           { $1 }
 
 {
+
 parseError :: [Located CoreToken] -> RLPC SrcError a
 parseError (Located y x l _ : _) = addFatal err
     where err = SrcError
@@ -165,5 +177,17 @@ parseTmp = do
     where
         parse = evalRLPC def . (lexCore >=> parseCore)
 
+exprPragma :: [String] -> RLPC SrcError Expr
+exprPragma ("AST" : e) = astPragma e
+exprPragma _           = addFatal err
+    where err = SrcError
+            { _errSpan       = (0,0,0) -- TODO: span
+            , _errSeverity   = Warning
+            , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
+            }
+
+astPragma :: [String] -> RLPC SrcError Expr
+astPragma = pure . read . unwords
+
 }
 

src/Core/Syntax.hs

@@ -38,7 +38,7 @@ data Expr = Var Name
           | Lam [Name] Expr
           | App Expr Expr
           | IntE Int
-          deriving (Show, Lift, Eq)
+          deriving (Show, Read, Lift, Eq)
 
 infixl 2 :$
 pattern (:$) :: Expr -> Expr -> Expr
@@ -47,7 +47,7 @@ pattern f :$ x = App f x
 {-# COMPLETE Binding :: Binding #-}
 {-# COMPLETE (:=) :: Binding #-}
 data Binding = Binding Name Expr
-    deriving (Show, Lift, Eq)
+    deriving (Show, Read, Lift, Eq)
 
 infixl 1 :=
 pattern (:=) :: Name -> Expr -> Binding
@@ -55,10 +55,10 @@ pattern k := v = Binding k v
 
 data Rec = Rec
          | NonRec
-         deriving (Show, Eq, Lift)
+         deriving (Show, Read, Eq, Lift)
 
 data Alter = Alter Tag [Name] Expr
-    deriving (Show, Lift, Eq)
+    deriving (Show, Read, Lift, Eq)
 
 type Name = String
 type Tag = Int