{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}

-- |  Parse an SExp representaton of our tree-walk language.

module Gibbon.SExpFrontend
       ( parseFile
       , parseSExp
       , primMap )
  where

import Control.Monad
import Data.Char ( isLower, isAlpha )
import qualified Data.List as L
import Data.Loc ( Loc(..), Pos(..))
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Text hiding (map, head, init, last, length, zip, reverse, foldr)
import qualified Data.Text as T
import Data.Text.IO (readFile)
import System.FilePath
import Text.Parsec
import Text.PrettyPrint.GenericPretty
import Prelude hiding (readFile, exp)

-- There are several options for s-expression parsing, including these
-- packages on Hackage:
--  * sexp
--  * sexpr
--  * sexp-grammar
--  * atto-lisp
--  * lispparser
-- Using 's-cargo' for the first attempt:
import Data.SCargot.Language.HaskLike
import Data.SCargot.Parse
import Data.SCargot.Print
import Data.SCargot.Repr -- (SExpr, RichSExpr, toRich)
import qualified Data.SCargot.Common as SC

import Gibbon.L0.Syntax
import Gibbon.Common

--------------------------------------------------------------------------------

-- | Baseline chatter level for this module:
lvl :: Int
lvl :: Int
lvl = Int
5

deriving instance Generic (SExpr a)
deriving instance Generic (RichSExpr a)
deriving instance Generic HaskLikeAtom
instance (Generic a, Out a) => Out (SExpr a)
instance (Generic a, Out a) => Out (RichSExpr a)
instance Out HaskLikeAtom
instance Out Text where
  doc :: Text -> Doc
doc Text
t = String -> Doc
forall a. Out a => a -> Doc
doc (Text -> String
T.unpack Text
t)
  docPrec :: Int -> Text -> Doc
docPrec Int
n Text
t = Int -> String -> Doc
forall a. Out a => Int -> a -> Doc
docPrec Int
n (Text -> String
T.unpack Text
t)

type Sexp = RichSExpr (SC.Located HaskLikeAtom)

prnt :: Sexp -> String
prnt :: Sexp -> String
prnt = Text -> String
T.unpack (Text -> String) -> (Sexp -> Text) -> Sexp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExprPrinter (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
-> SExpr (Located HaskLikeAtom) -> Text
forall atom carrier. SExprPrinter atom carrier -> carrier -> Text
encodeOne SExprPrinter (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
locatedHaskLikePrinter (SExpr (Located HaskLikeAtom) -> Text)
-> (Sexp -> SExpr (Located HaskLikeAtom)) -> Sexp -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sexp -> SExpr (Located HaskLikeAtom)
forall atom. RichSExpr atom -> SExpr atom
fromRich

textToVar :: Text -> Var
textToVar :: Text -> Var
textToVar = String -> Var
toVar (String -> Var) -> (Text -> String) -> Text -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

textToDataCon :: Text -> DataCon
textToDataCon :: Text -> String
textToDataCon = Text -> String
T.unpack

-- | Convert Location (s-cargot) to Loc (Data.Loc)
-- s-cargot uses SrcPos exported by Parsec whereas Data.Loc has it's own notion of Pos
toLoc :: SC.Location -> Loc
toLoc :: Location -> Loc
toLoc (SC.Span SourcePos
start SourcePos
end) = Pos -> Pos -> Loc
Loc (SourcePos -> Pos
toPos SourcePos
start) (SourcePos -> Pos
toPos SourcePos
end)

toPos :: SourcePos -> Pos
toPos :: SourcePos -> Pos
toPos SourcePos
sp = String -> Int -> Int -> Int -> Pos
Pos String
name Int
line Int
col Int
0
  where name :: String
name = SourcePos -> String
sourceName SourcePos
sp
        line :: Int
line = SourcePos -> Int
sourceLine SourcePos
sp
        col :: Int
col  = SourcePos -> Int
sourceColumn SourcePos
sp

-- Ideally, we'd extend the parser to ignore #lang lines.
-- But for now we'll just do that in a preprocessing hack.
treelangParser :: SExprParser (SC.Located HaskLikeAtom) (SExpr (SC.Located  HaskLikeAtom))
treelangParser :: SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
treelangParser =
    let langline :: ParsecT Text () Identity ()
langline = String -> ParsecT Text () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"#lang " ParsecT Text () Identity String
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity ()
forall {u}. ParsecT Text u Identity ()
eatline
        comment :: ParsecT Text () Identity ()
comment  = String -> ParsecT Text () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
";"      ParsecT Text () Identity String
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity ()
forall {u}. ParsecT Text u Identity ()
eatline
        eatline :: ParsecT Text u Identity ()
eatline  = ParsecT Text u Identity Char
-> ParsecT Text u Identity Char -> ParsecT Text u Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline ParsecT Text u Identity String
-> ParsecT Text u Identity () -> ParsecT Text u Identity ()
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT Text u Identity ()
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        quote :: SExpr atom -> SExpr atom
quote SExpr atom
expr     = SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (atom -> SExpr atom
forall atom. atom -> SExpr atom
SAtom atom
"quote") (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
expr SExpr atom
forall atom. SExpr atom
SNil)
        addQuoteReader :: SExprParser (Located HaskLikeAtom) c
-> SExprParser (Located HaskLikeAtom) c
addQuoteReader = Char
-> Reader (Located HaskLikeAtom)
-> SExprParser (Located HaskLikeAtom) c
-> SExprParser (Located HaskLikeAtom) c
forall a c. Char -> Reader a -> SExprParser a c -> SExprParser a c
addReader Char
'\'' (\ Parser (SExpr (Located HaskLikeAtom))
parse -> (SExpr (Located HaskLikeAtom) -> SExpr (Located HaskLikeAtom))
-> Reader (Located HaskLikeAtom)
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SExpr (Located HaskLikeAtom) -> SExpr (Located HaskLikeAtom)
forall {atom}. IsString atom => SExpr atom -> SExpr atom
quote Parser (SExpr (Located HaskLikeAtom))
parse)
    in
    -- setCarrier (return . asRich) $
        ParsecT Text () Identity ()
-> SExprParser
     (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
-> SExprParser
     (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
forall a c.
ParsecT Text () Identity () -> SExprParser a c -> SExprParser a c
setComment (ParsecT Text () Identity ()
comment ParsecT Text () Identity ()
-> ParsecT Text () Identity () -> ParsecT Text () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity ()
langline) (SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
 -> SExprParser
      (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom)))
-> SExprParser
     (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
-> SExprParser
     (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
forall a b. (a -> b) -> a -> b
$
        SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
-> SExprParser
     (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
forall {c}.
SExprParser (Located HaskLikeAtom) c
-> SExprParser (Located HaskLikeAtom) c
addQuoteReader SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
locatedHaskLikeParser

-- Hack:
_stripHashLang :: Text -> Text
_stripHashLang :: Text -> Text
_stripHashLang Text
txt =
  if Text -> Text -> Bool
T.isPrefixOf Text
"#lang" Text
txt
  then (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
txt
       -- (\c -> generalCategory c == LineSeparator)
  else Text
txt

bracketHacks :: Text -> Text
bracketHacks :: Text -> Text
bracketHacks = (Char -> Char) -> Text -> Text
T.map ((Char -> Char) -> Text -> Text) -> (Char -> Char) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \case Char
'[' -> Char
'('
                             Char
']' -> Char
')'
                             Char
x   -> Char
x

-- | Change regular applications into data constructor syntax.
tagDataCons :: DDefs Ty0 -> Exp0 -> PassM Exp0
tagDataCons :: DDefs Ty0 -> Exp0 -> PassM Exp0
tagDataCons DDefs Ty0
ddefs = Set Var -> Exp0 -> PassM Exp0
go Set Var
allCons
  where
   allCons :: Set Var
allCons = [Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList [ (String -> Var
toVar String
con)
                        | DDef{[(String, [(Bool, Ty0)])]
dataCons :: [(String, [(Bool, Ty0)])]
dataCons :: forall a. DDef a -> [(String, [(Bool, a)])]
dataCons} <- DDefs Ty0 -> [DDef Ty0]
forall k a. Map k a -> [a]
M.elems DDefs Ty0
ddefs
                        , (String
con,[(Bool, Ty0)]
_tys) <- [(String, [(Bool, Ty0)])]
dataCons ]

   go :: S.Set Var -> Exp0 -> PassM Exp0
   go :: Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
ex =
     case Exp0
ex of
       -- [2019.02.01] CSK: Do we need this special case ?
       AppE Var
v [Ty0]
_ [Exp0]
ls
                  | Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
cons -> do
                      Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
                      Ty0 -> String -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
ty (Var -> String
fromVar Var
v) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls)
       AppE Var
v [Ty0]
l [Exp0]
ls | Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
cons -> do Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
                                           Ty0 -> String -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
ty (Var -> String
fromVar Var
v) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls
                   | Bool
otherwise       -> Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [Ty0]
l ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls

       SpawnE Var
v [Ty0]
_ [Exp0]
ls
                  | Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
cons -> do
                      Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
                      Ty0 -> String -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
ty (Var -> String
fromVar Var
v) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls)
       SpawnE Var
v [Ty0]
l [Exp0]
ls | Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
cons -> do Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
                                             Ty0 -> String -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
ty (Var -> String
fromVar Var
v) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls
                   | Bool
otherwise       -> Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
v [Ty0]
l ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls

       LetE (Var
v,[Ty0]
l,Ty0
t,Exp0
rhs) Exp0
bod -> do
         let go' :: Exp0 -> PassM Exp0
go' = if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
cons
                      then Set Var -> Exp0 -> PassM Exp0
go (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
v Set Var
cons)
                      else Set Var -> Exp0 -> PassM Exp0
go Set Var
cons
         (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE ((Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0)
-> (Exp0 -> (Var, [Ty0], Ty0, Exp0)) -> Exp0 -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var
v,[Ty0]
l,Ty0
t,) (Exp0 -> Exp0 -> Exp0) -> PassM Exp0 -> PassM (Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp0 -> PassM Exp0
go' Exp0
rhs PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp0 -> PassM Exp0
go' Exp0
bod)
       ------------boilerplate------------
       VarE{}          -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
       LitSymE{}       -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
       LitE Int
_          -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
       CharE Char
_         -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
       FloatE Double
_        -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
       PrimAppE Prim Ty0
p [Exp0]
ls   -> Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
p ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls
       ProjE Int
i Exp0
e  -> Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e)
       CaseE Exp0
e [(String, [(Var, Ty0)], Exp0)]
ls -> Exp0 -> [(String, [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp0 -> [(String, [(Var, Ty0)], Exp0)] -> Exp0)
-> PassM Exp0 -> PassM ([(String, [(Var, Ty0)], Exp0)] -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e) PassM ([(String, [(Var, Ty0)], Exp0)] -> Exp0)
-> PassM [(String, [(Var, Ty0)], Exp0)] -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (((String, [(Var, Ty0)], Exp0)
 -> PassM (String, [(Var, Ty0)], Exp0))
-> [(String, [(Var, Ty0)], Exp0)]
-> PassM [(String, [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(String
c,[(Var, Ty0)]
vs,Exp0
er) -> (String
c,[(Var, Ty0)]
vs,) (Exp0 -> (String, [(Var, Ty0)], Exp0))
-> PassM Exp0 -> PassM (String, [(Var, Ty0)], Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
er) [(String, [(Var, Ty0)], Exp0)]
ls)
       MkProdE [Exp0]
ls     -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls
       DataConE Ty0
loc String
k [Exp0]
ls -> Ty0 -> String -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
loc String
k ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls
       TimeIt Exp0
e Ty0
t Bool
b -> do Exp0
e' <- (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e)
                          Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Ty0 -> Bool -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp0
e' Ty0
t Bool
b
       IfE Exp0
a Exp0
b Exp0
c -> Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0 -> Exp0 -> Exp0)
-> PassM Exp0 -> PassM (Exp0 -> Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
a) PassM (Exp0 -> Exp0 -> Exp0) -> PassM Exp0 -> PassM (Exp0 -> Exp0)
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
b) PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
c)
       WithArenaE Var
v Exp0
e -> Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e)

       MapE  (Var
v,Ty0
t,Exp0
e) Exp0
bod -> (Var, Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
MapE ((Var, Ty0, Exp0) -> Exp0 -> Exp0)
-> (Exp0 -> (Var, Ty0, Exp0)) -> Exp0 -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var
v,Ty0
t, ) (Exp0 -> Exp0 -> Exp0) -> PassM Exp0 -> PassM (Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
bod)
       FoldE (Var
v1,Ty0
t1,Exp0
e1) (Var
v2,Ty0
t2,Exp0
e2) Exp0
b -> do
         Exp0
e1' <- Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e1
         Exp0
e2' <- Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e2
         Exp0
b'  <- Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
b
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ (Var, Ty0, Exp0) -> (Var, Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> (Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec
-> PreExp ext loc dec
FoldE (Var
v1,Ty0
t1,Exp0
e1') (Var
v2,Ty0
t2,Exp0
e2') Exp0
b'
       Exp0
SyncE -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE
       Ext (LambdaE [(Var, Ty0)]
bnds Exp0
e) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Var, Ty0)] -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
[(Var, dec)] -> PreExp E0Ext loc dec -> E0Ext loc dec
LambdaE [(Var, Ty0)]
bnds) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e)
       Ext (PolyAppE Exp0
a Exp0
b)   -> do
         Exp0
a' <- Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
a
         Exp0
b' <- Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
b
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
PreExp E0Ext loc dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PolyAppE Exp0
a' Exp0
b'
       Ext (FunRefE{}) -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp0
ex
       Ext (BenchE Var
v [Ty0]
tyapps [Exp0]
es Bool
b) -> do
         [Exp0]
es' <- (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
es
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Bool -> E0Ext Ty0 Ty0
forall loc dec.
Var -> [loc] -> [PreExp E0Ext loc dec] -> Bool -> E0Ext loc dec
BenchE Var
v [Ty0]
tyapps [Exp0]
es' Bool
b
       Ext (ParE0 [Exp0]
ls) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0)
-> ([Exp0] -> E0Ext Ty0 Ty0) -> [Exp0] -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM Exp0) -> [Exp0] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Set Var -> Exp0 -> PassM Exp0
go Set Var
cons) [Exp0]
ls
       Ext (PrintPacked Ty0
ty Exp0
arg) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked Ty0
ty) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
arg
       Ext (CopyPacked Ty0
ty Exp0
arg) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked Ty0
ty) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
arg
       Ext (TravPacked Ty0
ty Exp0
arg) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked Ty0
ty) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
arg
       Ext (L Loc
p Exp0
e)    -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L Loc
p) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Var -> Exp0 -> PassM Exp0
go Set Var
cons Exp0
e
       Ext (LinearExt{}) -> String -> PassM Exp0
forall a. HasCallStack => String -> a
error (String -> PassM Exp0) -> String -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ String
"tagDataCons: SExpFrontend doesn't support linear types yet."


-- | Convert from raw, unstructured S-Expression into the L1 program datatype we expect.
parseSExp :: [Sexp] -> PassM Prog0
parseSExp :: [Sexp] -> PassM Prog0
parseSExp [Sexp]
ses = do
  prog :: Prog0
prog@Prog {DDefs (TyOf Exp0)
ddefs :: DDefs (TyOf Exp0)
ddefs :: forall ex. Prog ex -> DDefs (TyOf ex)
ddefs} <- [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
ses [] [] [] Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
  (Exp0 -> PassM Exp0) -> Prog0 -> PassM Prog0
forall (m :: * -> *) e.
Monad m =>
(e -> m e) -> Prog e -> m (Prog e)
mapMExprs (DDefs Ty0 -> Exp0 -> PassM Exp0
tagDataCons DDefs (TyOf Exp0)
DDefs Ty0
ddefs) Prog0
prog
 where

   -- WARNING: top-level constant definitions are INLINED everywhere.
   inlineConstDefs :: [(Var, b, PreExp e l d)]
-> Prog (PreExp e l d) -> Prog (PreExp e l d)
inlineConstDefs [] Prog (PreExp e l d)
p = Prog (PreExp e l d)
p
   inlineConstDefs ((Var
vr,b
_ty,PreExp e l d
rhs) : [(Var, b, PreExp e l d)]
cds) Prog (PreExp e l d)
p =
       [(Var, b, PreExp e l d)]
-> Prog (PreExp e l d) -> Prog (PreExp e l d)
inlineConstDefs [(Var, b, PreExp e l d)]
cds (Prog (PreExp e l d) -> Prog (PreExp e l d))
-> Prog (PreExp e l d) -> Prog (PreExp e l d)
forall a b. (a -> b) -> a -> b
$
        (PreExp e l d -> PreExp e l d)
-> Prog (PreExp e l d) -> Prog (PreExp e l d)
forall e. (e -> e) -> Prog e -> Prog e
mapExprs (Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst Var
vr PreExp e l d
rhs) Prog (PreExp e l d)
p

   -- Processes an sexpression while accumulating data, function, and constant defs.
   go :: [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
xs [DDef Ty0]
dds [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn =
    case [Sexp]
xs of
     [] -> Prog0 -> PassM Prog0
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog0 -> PassM Prog0) -> Prog0 -> PassM Prog0
forall a b. (a -> b) -> a -> b
$
           [(Var, Sexp, Exp0)] -> Prog0 -> Prog0
forall {e :: * -> * -> *} {l} {d} {b}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
[(Var, b, PreExp e l d)]
-> Prog (PreExp e l d) -> Prog (PreExp e l d)
inlineConstDefs [(Var, Sexp, Exp0)]
cds (Prog0 -> Prog0) -> Prog0 -> Prog0
forall a b. (a -> b) -> a -> b
$
           DDefs (TyOf Exp0)
-> FunDefs Exp0 -> Maybe (Exp0, TyOf Exp0) -> Prog0
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog ([DDef Ty0] -> DDefs Ty0
forall a. [DDef a] -> DDefs a
fromListDD [DDef Ty0]
dds) ([FunDef Exp0] -> FunDefs Exp0
forall ex. [FunDef ex] -> FunDefs ex
fromListFD [FunDef Exp0]
fds) Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
mn

     -- IGNORED!:
     (Ls (A Location
_ Text
"provide":[Sexp]
_) : [Sexp]
rst) -> [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst [DDef Ty0]
dds [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn
     (Ls (A Location
_ Text
"require":[Sexp]
_) : [Sexp]
rst) -> [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst [DDef Ty0]
dds [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn

{-

Polymorphic datatypes:

    (data PolyD (a b) [K3 ... a b ...])

While parsing datatypes with type variables, 'isTyVar' decides
if a thing is a type variable or a data constructor.

-}
     (Ls (A Location
_ Text
"data": A Location
_ Text
tycon  : [Sexp]
cs) : [Sexp]
rst) -> do
       let tycon' :: Var
tycon' = Text -> Var
textToVar Text
tycon
       case [Sexp]
cs of
         [] -> [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst ((Var -> [TyVar] -> [(String, [(Bool, Ty0)])] -> DDef Ty0
forall a. Var -> [TyVar] -> [(String, [(Bool, a)])] -> DDef a
DDef Var
tycon' [] []) DDef Ty0 -> [DDef Ty0] -> [DDef Ty0]
forall a. a -> [a] -> [a]
: [DDef Ty0]
dds) [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn
         (Ls [Sexp]
k) : [Sexp]
ks ->
           case [Sexp]
k of
             [] -> [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst ((Var -> [TyVar] -> [(String, [(Bool, Ty0)])] -> DDef Ty0
forall a. Var -> [TyVar] -> [(String, [(Bool, a)])] -> DDef a
DDef Var
tycon' [] ((Sexp -> (String, [(Bool, Ty0)]))
-> [Sexp] -> [(String, [(Bool, Ty0)])]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> (String, [(Bool, Ty0)])
docasety [Sexp]
cs)) DDef Ty0 -> [DDef Ty0] -> [DDef Ty0]
forall a. a -> [a] -> [a]
: [DDef Ty0]
dds) [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn
             (A Location
_ Text
tyvar_or_constr : [Sexp]
_) ->
               if Text -> Bool
isTyVar Text
tyvar_or_constr
               then do let tyargs :: [TyVar]
tyargs = (Sexp -> TyVar) -> [Sexp] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
L.map (Var -> TyVar
UserTv (Var -> TyVar) -> (Sexp -> Var) -> Sexp -> TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sexp -> Var
getSym) [Sexp]
k
                       [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst (Var -> [TyVar] -> [(String, [(Bool, Ty0)])] -> DDef Ty0
forall a. Var -> [TyVar] -> [(String, [(Bool, a)])] -> DDef a
DDef (Text -> Var
textToVar Text
tycon) [TyVar]
tyargs ((Sexp -> (String, [(Bool, Ty0)]))
-> [Sexp] -> [(String, [(Bool, Ty0)])]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> (String, [(Bool, Ty0)])
docasety [Sexp]
ks) DDef Ty0 -> [DDef Ty0] -> [DDef Ty0]
forall a. a -> [a] -> [a]
: [DDef Ty0]
dds) [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn
               else [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst (Var -> [TyVar] -> [(String, [(Bool, Ty0)])] -> DDef Ty0
forall a. Var -> [TyVar] -> [(String, [(Bool, a)])] -> DDef a
DDef (Text -> Var
textToVar Text
tycon) [] ((Sexp -> (String, [(Bool, Ty0)]))
-> [Sexp] -> [(String, [(Bool, Ty0)])]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> (String, [(Bool, Ty0)])
docasety [Sexp]
cs) DDef Ty0 -> [DDef Ty0] -> [DDef Ty0]
forall a. a -> [a] -> [a]
: [DDef Ty0]
dds) [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn
             [Sexp]
_ -> String -> PassM Prog0
forall a. HasCallStack => String -> a
error (String -> PassM Prog0) -> String -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ String
"Unexpected constructor while parsing data: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Sexp] -> String
forall a. Show a => a -> String
show [Sexp]
k
         [Sexp]
_ -> String -> PassM Prog0
forall a. HasCallStack => String -> a
error (String -> PassM Prog0) -> String -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ String
"Unexpected constructors while parsing data: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Sexp] -> String
forall a. Show a => a -> String
show [Sexp]
cs

     (Ls [A Location
_ Text
"define", Sexp
funspec, A Location
_ Text
":", Sexp
retty, Sexp
bod] : [Sexp]
rst)
         |  RSList (A Location
_ Text
name : [Sexp]
args) <- Sexp
funspec
        -> do
         Exp0
bod' <- Sexp -> PassM Exp0
exp Sexp
bod
         let args' :: [(Var, Ty0)]
args' = (Sexp -> (Var, Ty0)) -> [Sexp] -> [(Var, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(RSList [Sexp
id, A Location
_ Text
":",Sexp
t]) -> (Sexp -> Var
getSym Sexp
id, Sexp -> Ty0
typ Sexp
t)) [Sexp]
args
             ([Var]
args'', [Ty0]
arg_tys) = [(Var, Ty0)] -> ([Var], [Ty0])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Ty0)]
args'
         let fun_ty :: Ty0
fun_ty = [Ty0] -> Ty0 -> Ty0
ArrowTy [Ty0]
arg_tys (Sexp -> Ty0
typ Sexp
retty)
         [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst [DDef Ty0]
dds (FunDef { funName :: Var
funName = Text -> Var
textToVar Text
name
                            , funArgs :: [Var]
funArgs = [Var]
args''
                            , funTy :: ArrowTy (TyOf Exp0)
funTy   = [TyVar] -> Ty0 -> TyScheme
ForAll (Ty0 -> [TyVar]
tyVarsInTy Ty0
fun_ty) Ty0
fun_ty
                            , funBody :: Exp0
funBody = Exp0
bod'
                            , funMeta :: FunMeta
funMeta = FunMeta { funRec :: FunRec
funRec = FunRec
NotRec
                                                , funInline :: FunInline
funInline = FunInline
NoInline
                                                , funCanTriggerGC :: Bool
funCanTriggerGC = Bool
False
                                                }
                            } FunDef Exp0 -> [FunDef Exp0] -> [FunDef Exp0]
forall a. a -> [a] -> [a]
: [FunDef Exp0]
fds)
            [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn

     -- Top-level definition instead of a function.
     (Ls [A Location
_ Text
"define", A Location
_ Text
topid, A Location
_ Text
":", Sexp
ty, Sexp
bod] : [Sexp]
rst) -> do
       Exp0
bod' <- Sexp -> PassM Exp0
exp Sexp
bod
       [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst [DDef Ty0]
dds [FunDef Exp0]
fds ((Text -> Var
textToVar Text
topid,Sexp
ty,Exp0
bod') (Var, Sexp, Exp0) -> [(Var, Sexp, Exp0)] -> [(Var, Sexp, Exp0)]
forall a. a -> [a] -> [a]
: [(Var, Sexp, Exp0)]
cds) Maybe (Exp0, Ty0)
mn

     (Ls [A Location
_ Text
"define", Sexp
_args, Sexp
_bod] : [Sexp]
_) -> String -> PassM Prog0
forall a. HasCallStack => String -> a
error(String -> PassM Prog0) -> String -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ String
"Function is missing return type:\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt ([Sexp] -> Sexp
forall a. HasCallStack => [a] -> a
head [Sexp]
xs)
     (Ls (A Location
_ Text
"define" : [Sexp]
_) : [Sexp]
_) -> String -> PassM Prog0
forall a. HasCallStack => String -> a
error(String -> PassM Prog0) -> String -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ String
"Badly formed function:\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
forall a. Show a => a -> String
show ([Sexp] -> Sexp
forall a. HasCallStack => [a] -> a
head [Sexp]
xs)

     (Ls (A Location
_ Text
"data" : [Sexp]
_) : [Sexp]
_) -> String -> PassM Prog0
forall a. HasCallStack => String -> a
error(String -> PassM Prog0) -> String -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ String
"Badly formed data definition:\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt ([Sexp] -> Sexp
forall a. HasCallStack => [a] -> a
head [Sexp]
xs)

     (Ls3 Location
_ Text
"module+" Sexp
_ Sexp
bod : [Sexp]
rst) -> [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go (Sexp
bodSexp -> [Sexp] -> [Sexp]
forall a. a -> [a] -> [a]
:[Sexp]
rst) [DDef Ty0]
dds [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds Maybe (Exp0, Ty0)
mn

     (Sexp
ex : [Sexp]
rst) -> do
       Exp0
ex' <- Sexp -> PassM Exp0
exp Sexp
ex
       Ty0
ty  <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       [Sexp]
-> [DDef Ty0]
-> [FunDef Exp0]
-> [(Var, Sexp, Exp0)]
-> Maybe (Exp0, Ty0)
-> PassM Prog0
go [Sexp]
rst [DDef Ty0]
dds [FunDef Exp0]
fds [(Var, Sexp, Exp0)]
cds (case Maybe (Exp0, Ty0)
mn of
                                -- Initialize the main expression with a void type.
                                -- The typechecker will fix it later.
                                Maybe (Exp0, Ty0)
Nothing -> (Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just (Exp0
ex', Ty0
ty)
                                Just (Exp0, Ty0)
x  -> String -> Maybe (Exp0, Ty0)
forall a. HasCallStack => String -> a
error(String -> Maybe (Exp0, Ty0)) -> String -> Maybe (Exp0, Ty0)
forall a b. (a -> b) -> a -> b
$ String
"Two main expressions: "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                 (Exp0, Ty0) -> String
forall a. Out a => a -> String
sdoc (Exp0, Ty0)
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nAnd:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
ex)

typ :: Sexp -> Ty0
typ :: Sexp -> Ty0
typ Sexp
s = case Sexp
s of
         (A Location
_ Text
"Int")  -> Ty0
IntTy
         (A Location
_ Text
"Sym")  -> Ty0
SymTy0
         (A Location
_ Text
"SymSet") -> Ty0
SymSetTy
         (A Location
_ Text
"SymHash") -> Ty0
SymHashTy
         (A Location
_ Text
"Bool") -> Ty0
BoolTy
         (A Location
_ Text
"Arena") -> Ty0
ArenaTy
         (A Location
_ Text
"Void")  -> [Ty0] -> Ty0
ProdTy []
         -- If it's lowercase, it's a type variable. Otherwise, a Packed type.
         (A Location
_ Text
con)    -> if Text -> Bool
isTyVar Text
con
                         then TyVar -> Ty0
TyVar (TyVar -> Ty0) -> TyVar -> Ty0
forall a b. (a -> b) -> a -> b
$ Var -> TyVar
UserTv (Text -> Var
textToVar Text
con)
                         else String -> [Ty0] -> Ty0
PackedTy (Text -> String
textToDataCon Text
con) []
         (Ls3 Location
_ Text
"SymDict" (A Location
_ Text
v) Sexp
t) -> Maybe Var -> Ty0 -> Ty0
SymDictTy (Var -> Maybe Var
forall a. a -> Maybe a
Just (Text -> Var
textToVar Text
v)) (Sexp -> Ty0
typ Sexp
t)
         (Ls2 Location
_ Text
"VectorOf" Sexp
t)  -> Ty0 -> Ty0
VectorTy (Ty0 -> Ty0) -> Ty0 -> Ty0
forall a b. (a -> b) -> a -> b
$ Sexp -> Ty0
typ Sexp
t
         -- See https://github.com/aisamanra/s-cargot/issues/14.
         (Ls (A Location
_ Text
"-" : A Location
_ Text
">" : [Sexp]
tys)) ->
             let tys' :: [Ty0]
tys'   = (Sexp -> Ty0) -> [Sexp] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> Ty0
typ [Sexp]
tys
             in [Ty0] -> Ty0 -> Ty0
ArrowTy ([Ty0] -> [Ty0]
forall a. HasCallStack => [a] -> [a]
init [Ty0]
tys') ([Ty0] -> Ty0
forall a. HasCallStack => [a] -> a
last [Ty0]
tys')
         (Ls (A Location
_ Text
"Vector"  : [Sexp]
rst)) -> [Ty0] -> Ty0
ProdTy ([Ty0] -> Ty0) -> [Ty0] -> Ty0
forall a b. (a -> b) -> a -> b
$ (Sexp -> Ty0) -> [Sexp] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> Ty0
typ [Sexp]
rst
         (Ls (A Location
_ Text
tycon : [Sexp]
tyargs))  -> String -> [Ty0] -> Ty0
PackedTy (Text -> String
textToDataCon Text
tycon) ((Sexp -> Ty0) -> [Sexp] -> [Ty0]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> Ty0
typ [Sexp]
tyargs)
         Sexp
_ -> String -> Ty0
forall a. HasCallStack => String -> a
error(String -> Ty0) -> String -> Ty0
forall a b. (a -> b) -> a -> b
$ String
"SExpression encodes invalid type:\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sexp -> String
forall a. Show a => a -> String
show Sexp
s

-- Some text is a tyvar if it starts with a lowercase alphabet.
isTyVar :: Text -> Bool
isTyVar :: Text -> Bool
isTyVar Text
t = Char -> Bool
isLower Char
h Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
h
  where h :: Char
h = HasCallStack => Text -> Char
Text -> Char
T.head Text
t

getSym :: Sexp -> Var
getSym :: Sexp -> Var
getSym (A Location
_ Text
id) = Text -> Var
textToVar Text
id
getSym Sexp
s = String -> Var
forall a. HasCallStack => String -> a
error (String -> Var) -> String -> Var
forall a b. (a -> b) -> a -> b
$ String
"expected identifier sexpr, got: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
s

docasety :: Sexp -> (DataCon,[(IsBoxed,Ty0)])
docasety :: Sexp -> (String, [(Bool, Ty0)])
docasety Sexp
s =
  case Sexp
s of
    (RSList ((A Location
_ Text
id) : [Sexp]
tys)) -> (Text -> String
textToDataCon Text
id, (Sexp -> (Bool, Ty0)) -> [Sexp] -> [(Bool, Ty0)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Bool
False,) (Ty0 -> (Bool, Ty0)) -> (Sexp -> Ty0) -> Sexp -> (Bool, Ty0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sexp -> Ty0
typ) [Sexp]
tys)
    Sexp
_ -> String -> (String, [(Bool, Ty0)])
forall a. HasCallStack => String -> a
error(String -> (String, [(Bool, Ty0)]))
-> String -> (String, [(Bool, Ty0)])
forall a b. (a -> b) -> a -> b
$ String
"Badly formed variant of datatype:\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
s

pattern $mA :: forall {r}. Sexp -> (Location -> Text -> r) -> ((# #) -> r) -> r
$bA :: Location -> Text -> Sexp
A loc s = RSAtom (SC.At loc (HSIdent s))
pattern $mG :: forall {r} {a}.
RichSExpr (Located a) -> (Location -> a -> r) -> ((# #) -> r) -> r
$bG :: forall {a}. Location -> a -> RichSExpr (Located a)
G loc s = RSAtom (SC.At loc s)
pattern $mLs :: forall {r} {atom}.
RichSExpr atom -> ([RichSExpr atom] -> r) -> ((# #) -> r) -> r
$bLs :: forall {atom}. [RichSExpr atom] -> RichSExpr atom
Ls a              = RSList a
pattern $mLs1 :: forall {r} {atom}.
RichSExpr atom -> (RichSExpr atom -> r) -> ((# #) -> r) -> r
$bLs1 :: forall {atom}. RichSExpr atom -> RichSExpr atom
Ls1 a             = RSList [a]
pattern $mLs2 :: forall {r}.
Sexp -> (Location -> Text -> Sexp -> r) -> ((# #) -> r) -> r
$bLs2 :: Location -> Text -> Sexp -> Sexp
Ls2 loc a b       = RSList [A loc a, b]
pattern $mLs3 :: forall {r}.
Sexp
-> (Location -> Text -> Sexp -> Sexp -> r) -> ((# #) -> r) -> r
$bLs3 :: Location -> Text -> Sexp -> Sexp -> Sexp
Ls3 loc a b c     = RSList [A loc a, b, c]
pattern $mLs4 :: forall {r}.
Sexp
-> (Location -> Text -> Sexp -> Sexp -> Sexp -> r)
-> ((# #) -> r)
-> r
$bLs4 :: Location -> Text -> Sexp -> Sexp -> Sexp -> Sexp
Ls4 loc a b c d   = RSList [A loc a, b, c, d]
pattern $mLs5 :: forall {r}.
Sexp
-> (Location -> Text -> Sexp -> Sexp -> Sexp -> Sexp -> r)
-> ((# #) -> r)
-> r
$bLs5 :: Location -> Text -> Sexp -> Sexp -> Sexp -> Sexp -> Sexp
Ls5 loc a b c d e = RSList [A loc a, b, c, d, e]
-- pattern L5 a b c d e = RSList [A a, b, c, d, e]

trueE :: Exp0
trueE :: Exp0
trueE = Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
MkTrue []

falseE :: Exp0
falseE :: Exp0
falseE = Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
MkFalse []

-- -- FIXME: we cannot intern strings until runtime.
-- hackySymbol :: String -> Int
-- hackySymbol s = product (L.map ord s)

keywords :: S.Set Text
keywords :: Set Text
keywords = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map String -> Text
pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$
           [ String
"quote", String
"if", String
"or", String
"and", String
"time", String
"let", String
"let*"
           , String
"case", String
"vector-ref", String
"for/fold", String
"for/list"
           , String
"insert", String
"empty-dict", String
"lookup", String
"error", String
"ann"
           , String
"div", String
"mod", String
"exp", String
"rand"
           ]

isKeyword :: Text -> Bool
isKeyword :: Text -> Bool
isKeyword Text
s = Text
s Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
keywords

exp :: Sexp -> PassM Exp0
exp :: Sexp -> PassM Exp0
exp Sexp
se =
 case Sexp
se of
   A Location
l Text
"True"  -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0
trueE
   A Location
l Text
"False" -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0
falseE

   Ls [A Location
_ Text
"void"] -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE []

   Ls [] -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE []

   Ls ((A Location
l Text
"and") : [Sexp]
args)  -> [Sexp] -> PassM Exp0
go [Sexp]
args
     where
       go :: [Sexp] -> PassM Exp0
       go :: [Sexp] -> PassM Exp0
go [] = Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0
trueE
       go (Sexp
x:[Sexp]
xs) = do
         Exp0
x'  <- Sexp -> PassM Exp0
exp Sexp
x
         Exp0
xs' <- [Sexp] -> PassM Exp0
go [Sexp]
xs
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp0
x' Exp0
xs' Exp0
falseE

   Ls ((A Location
l Text
"or") : [Sexp]
args)  -> [Sexp] -> PassM Exp0
go [Sexp]
args
     where
       go :: [Sexp] -> PassM Exp0
       go :: [Sexp] -> PassM Exp0
go [] = Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Exp0
falseE
       go (Sexp
x:[Sexp]
xs) = do
         Exp0
x'  <- Sexp -> PassM Exp0
exp Sexp
x
         Exp0
xs' <- [Sexp] -> PassM Exp0
go [Sexp]
xs
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp0
x' Exp0
trueE Exp0
xs'

   Ls4 Location
l Text
"if" Sexp
test Sexp
conseq Sexp
altern -> do
     Exp0
e' <- Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp0 -> Exp0 -> Exp0 -> Exp0)
-> PassM Exp0 -> PassM (Exp0 -> Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0
exp Sexp
test) PassM (Exp0 -> Exp0 -> Exp0) -> PassM Exp0 -> PassM (Exp0 -> Exp0)
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Sexp -> PassM Exp0
exp Sexp
conseq) PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Sexp -> PassM Exp0
exp Sexp
altern)
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$  Exp0
e'

   Ls2 Location
l Text
"quote" (A Location
_ Text
v) -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
LitSymE (Text -> Var
textToVar Text
v)

   -- Any other naked symbol is a variable:
   A Location
l Text
v          -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Text -> Var
textToVar Text
v)
   G Location
l (HSInt Integer
n)  -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Int -> Exp0
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
   G Location
l (HSString Text
txt) -> do
     Var
vec <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"vec")
     let n :: Int
n = Text -> Int
T.length Text
txt
         init_vec :: Exp0 -> Exp0
init_vec = (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
vec,[],Ty0 -> Ty0
VectorTy Ty0
CharTy, Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VAllocP Ty0
CharTy) [Int -> Exp0
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
n])
         fn :: Int -> Char -> Exp0 -> Exp0
fn Int
i Char
c Exp0
b = (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
"_",[],Ty0 -> Ty0
VectorTy Ty0
CharTy,
                          Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
InplaceVUpdateP Ty0
CharTy) [Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vec, Int -> Exp0
forall (ext :: * -> * -> *) loc dec. Int -> PreExp ext loc dec
LitE Int
i, Char -> Exp0
forall (ext :: * -> * -> *) loc dec. Char -> PreExp ext loc dec
CharE Char
c])
                    Exp0
b
         add_chars :: Exp0
add_chars = ((Int, Char) -> Exp0 -> Exp0) -> Exp0 -> [(Int, Char)] -> Exp0
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i,Char
chr) Exp0
acc -> Int -> Char -> Exp0 -> Exp0
fn Int
i Char
chr Exp0
acc) (Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
vec)
                       ([(Int, Char)] -> [(Int, Char)]
forall a. [a] -> [a]
reverse ([(Int, Char)] -> [(Int, Char)]) -> [(Int, Char)] -> [(Int, Char)]
forall a b. (a -> b) -> a -> b
$ [Int] -> String -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] (Text -> String
T.unpack Text
txt))
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0
init_vec Exp0
add_chars

   -- This type gets replaced later in flatten:
   Ls2 Location
l Text
"time" Sexp
arg -> do
     Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
     Exp0
arg' <- Sexp -> PassM Exp0
exp Sexp
arg
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Ty0 -> Bool -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp0
arg' Ty0
ty Bool
False

   Ls3 Location
l Text
"bench" (A Location
_ Text
fn) Sexp
arg -> do
     Exp0
arg' <- Sexp -> PassM Exp0
exp Sexp
arg
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Bool -> E0Ext Ty0 Ty0
forall loc dec.
Var -> [loc] -> [PreExp E0Ext loc dec] -> Bool -> E0Ext loc dec
BenchE (Text -> Var
textToVar Text
fn) [] [Exp0
arg'] Bool
False

   -- This variant inserts a loop, controlled by the iters
   -- argument on the command line.
   Ls2 Location
l Text
"iterate" Sexp
arg -> do
     Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
     Exp0
arg' <- Sexp -> PassM Exp0
exp Sexp
arg
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Ty0 -> Bool -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp0
arg' Ty0
ty Bool
True

   Ls3 Location
l Text
"let" (Ls [Sexp]
bnds) Sexp
bod ->
     -- mkLets tacks on NoLoc's for every expression.
     -- Here, we remove the outermost NoLoc and tag with original src location
     E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0)
-> PassM [(Var, [Ty0], Ty0, Exp0)] -> PassM (Exp0 -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Sexp -> PassM (Var, [Ty0], Ty0, Exp0))
-> [Sexp] -> PassM [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM (Var, [Ty0], Ty0, Exp0)
forall l. Sexp -> PassM (Var, [l], Ty0, Exp0)
letbind [Sexp]
bnds) PassM (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Sexp -> PassM Exp0
exp Sexp
bod))

   Ls3 Location
l Text
"let*" (Ls []) Sexp
bod -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sexp -> PassM Exp0
exp Sexp
bod

   Ls3 Location
l Text
"let*" (Ls (Sexp
bnd:[Sexp]
bnds)) Sexp
bod -> do
     (Var, [Ty0], Ty0, Exp0)
bnd'  <- Sexp -> PassM (Var, [Ty0], Ty0, Exp0)
forall l. Sexp -> PassM (Var, [l], Ty0, Exp0)
letbind Sexp
bnd
     Exp0
bnds' <- Sexp -> PassM Exp0
exp (Sexp -> PassM Exp0) -> Sexp -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Location -> Text -> Sexp -> Sexp -> Sexp
Ls3 Location
l Text
"let*" ([Sexp] -> Sexp
forall {atom}. [RichSExpr atom] -> RichSExpr atom
Ls [Sexp]
bnds) Sexp
bod
      -- just like the `let` case above
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall loc dec (ext :: * -> * -> *).
[(Var, [loc], dec, PreExp ext loc dec)]
-> PreExp ext loc dec -> PreExp ext loc dec
mkLets [(Var, [Ty0], Ty0, Exp0)
bnd'] Exp0
bnds'

   Ls (A Location
l Text
"case": Sexp
scrut: [Sexp]
cases) -> do
     Exp0
e' <- Exp0 -> [(String, [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp0 -> [(String, [(Var, Ty0)], Exp0)] -> Exp0)
-> PassM Exp0 -> PassM ([(String, [(Var, Ty0)], Exp0)] -> Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0
exp Sexp
scrut) PassM ([(String, [(Var, Ty0)], Exp0)] -> Exp0)
-> PassM [(String, [(Var, Ty0)], Exp0)] -> PassM Exp0
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Sexp -> PassM (String, [(Var, Ty0)], Exp0))
-> [Sexp] -> PassM [(String, [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM (String, [(Var, Ty0)], Exp0)
docase [Sexp]
cases)
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Exp0
e'

   Ls (A Location
l Text
p : [Sexp]
ls) | Text -> Bool
isPrim Text
p -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> ([Exp0] -> Exp0) -> [Exp0] -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Text -> Prim Ty0
prim Text
p) ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0) -> [Sexp] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM Exp0
exp [Sexp]
ls

   Ls (A Location
l Text
"lambda" : Ls [Sexp]
args : [Sexp
bod]) -> do
     -- POLICY DECISION:
     -- Should we require type annotations on the arguments to a lambda ?
     -- Right now, we don't and initialize them with meta type variables.
     let args' :: [Var]
args' = (Sexp -> Var) -> [Sexp] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
L.map Sexp -> Var
getSym [Sexp]
args
     Exp0
bod' <- Sexp -> PassM Exp0
exp Sexp
bod
     [Ty0]
tys <- (Var -> PassM Ty0) -> [Var] -> PassM [Ty0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM  (\Var
_ -> PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy) [Var]
args'
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [(Var, Ty0)] -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
[(Var, dec)] -> PreExp E0Ext loc dec -> E0Ext loc dec
LambdaE ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
args' [Ty0]
tys) Exp0
bod'

   Ls2 Location
l Text
"print-packed" Sexp
arg -> do
     Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
     Exp0
arg' <- Sexp -> PassM Exp0
exp Sexp
arg
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
PrintPacked Ty0
ty Exp0
arg'

   Ls2 Location
l Text
"copy-packed" Sexp
arg -> do
     Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
     Exp0
arg' <- Sexp -> PassM Exp0
exp Sexp
arg
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
CopyPacked Ty0
ty Exp0
arg'

   Ls2 Location
l Text
"trav-packed" Sexp
arg -> do
     Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
     Exp0
arg' <- Sexp -> PassM Exp0
exp Sexp
arg
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
TravPacked Ty0
ty Exp0
arg'


   Ls3 Location
l Text
"for/list" (Ls1 (Ls4 Location
_ Text
v Sexp
":" Sexp
t Sexp
e)) Sexp
bod -> do
     Exp0
e'   <- Sexp -> PassM Exp0
exp Sexp
e
     Exp0
bod' <- Sexp -> PassM Exp0
exp Sexp
bod
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ (Var, Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
MapE (Text -> Var
textToVar Text
v, Sexp -> Ty0
typ Sexp
t, Exp0
e') Exp0
bod'

   -- I don't see why we need the extra type annotation:
   Ls4 Location
l Text
"for/fold"
          (Ls1 (Ls4 Location
_ Text
v1 Sexp
":" Sexp
t1 Sexp
e1))
          (Ls1 (Ls4 Location
_ Text
v2 Sexp
":" Sexp
t2 Sexp
e2))
          Sexp
bod -> do
     Exp0
e1'  <- Sexp -> PassM Exp0
exp Sexp
e1
     Exp0
e2'  <- Sexp -> PassM Exp0
exp Sexp
e2
     Exp0
bod' <- Sexp -> PassM Exp0
exp Sexp
bod
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$
                   (Var, Ty0, Exp0) -> (Var, Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, dec, PreExp ext loc dec)
-> (Var, dec, PreExp ext loc dec)
-> PreExp ext loc dec
-> PreExp ext loc dec
FoldE (Text -> Var
textToVar Text
v1, Sexp -> Ty0
typ Sexp
t1, Exp0
e1')
                          (Text -> Var
textToVar Text
v2, Sexp -> Ty0
typ Sexp
t2, Exp0
e2')
                          Exp0
bod'

   Ls2 Location
l Text
"eqBenchProg" (G Location
_ (HSString Text
str)) ->
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (String -> Prim Ty0
forall ty. String -> Prim ty
EqBenchProgP (Text -> String
T.unpack Text
str)) []))

   Ls3 Location
l Text
"vector-ref" Sexp
evec (G Location
_ (HSInt Integer
ind)) ->
     E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> (Exp0 -> Exp0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ind) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0
exp Sexp
evec)

   Ls (A Location
l Text
"par" : [Sexp]
es) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0)
-> ([Exp0] -> E0Ext Ty0 Ty0) -> [Exp0] -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp0] -> E0Ext Ty0 Ty0
forall loc dec. [PreExp E0Ext loc dec] -> E0Ext loc dec
ParE0 ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0) -> [Sexp] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM Exp0
exp [Sexp]
es

   Ls2 Location
l1 Text
"spawn" Sexp
app -> do
     Exp0
appe <- Sexp -> PassM Exp0
exp Sexp
app
     case Exp0
appe of
       Ext (L Loc
_loc (AppE Var
f [Ty0]
locs [Exp0]
args)) -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l1) (Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [Ty0]
locs [Exp0]
args)
       (AppE Var
f [Ty0]
locs [Exp0]
args) -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l1) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [Ty0]
locs [Exp0]
args
       Exp0
_ -> String -> PassM Exp0
forall a. HasCallStack => String -> a
error (String -> PassM Exp0) -> String -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ String
"Only function calls can be spawn'd. Got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sexp -> String
forall a. Show a => a -> String
show Sexp
app

   Ls (A Location
l1 Text
"sync":[]) -> do
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l1) Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE

   Ls3 Location
l0 Text
"is-big" Sexp
i Sexp
e -> do
       Exp0
ie <- Sexp -> PassM Exp0
exp Sexp
i
       Exp0
ee <- Sexp -> PassM Exp0
exp Sexp
e
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l0) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
forall ty. Prim ty
IsBig [Exp0
ie, Exp0
ee]

   Ls2 Location
_ Text
"read-packed-file" (A Location
_ Text
tycon) -> do
       let tcon :: String
tcon = Text -> String
T.unpack Text
tycon
           ty :: Ty0
ty = String -> [Ty0] -> Ty0
PackedTy String
tcon []
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Maybe String -> String -> Maybe Var -> Ty0 -> Prim Ty0
forall ty. Maybe String -> String -> Maybe Var -> ty -> Prim ty
ReadPackedFile Maybe String
forall a. Maybe a
Nothing String
tcon Maybe Var
forall a. Maybe a
Nothing Ty0
ty) []

   Ls3 Location
_l0 Text
"read-packed-file" (A Location
_ Text
tycon) Sexp
e -> do
       let tcon :: String
tcon = Text -> String
T.unpack Text
tycon
           ty :: Ty0
ty = String -> [Ty0] -> Ty0
PackedTy String
tcon []
       case Sexp
e of
           G Location
_ (HSString Text
str) -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Maybe String -> String -> Maybe Var -> Ty0 -> Prim Ty0
forall ty. Maybe String -> String -> Maybe Var -> ty -> Prim ty
ReadPackedFile (String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack Text
str)) (Text -> String
T.unpack Text
tycon) Maybe Var
forall a. Maybe a
Nothing Ty0
ty) []
           A Location
_ Text
str -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Maybe String -> String -> Maybe Var -> Ty0 -> Prim Ty0
forall ty. Maybe String -> String -> Maybe Var -> ty -> Prim ty
ReadPackedFile (String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack Text
str)) (Text -> String
T.unpack Text
tycon) Maybe Var
forall a. Maybe a
Nothing Ty0
ty) []
           Sexp
_ -> String -> PassM Exp0
forall a. HasCallStack => String -> a
error (String -> PassM Exp0) -> String -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ String
"Counldn't parse read-packed-file" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sexp -> String
forall a. Show a => a -> String
show Sexp
se

   Ls3 Location
l Text
"letarena" Sexp
v Sexp
e -> do
     Exp0
e' <- Sexp -> PassM Exp0
exp Sexp
e
     let v' :: Var
v' = Sexp -> Var
getSym Sexp
v
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Var -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v' Exp0
e'

   Ls (A Location
l Text
"vector" : [Sexp]
es) -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> ([Exp0] -> Exp0) -> [Exp0] -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0) -> [Sexp] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM Exp0
exp [Sexp]
es

   -- Dictionaries require type annotations for now.  No inference!
   Ls3 Location
l Text
"ann" (Ls2 Location
_ Text
"empty-dict" Sexp
a) (Ls3 Location
_ Text
"SymDict" Sexp
b Sexp
ty) -> do
     Exp0
a' <- Sexp -> PassM Exp0
exp Sexp
a
     Exp0
b' <- Sexp -> PassM Exp0
exp Sexp
b
     case (Exp0
a', Exp0
b') of
       (Ext (L Loc
_ Exp0
a''), Ext (L Loc
_ Exp0
b'')) -> do
         Bool -> PassM () -> PassM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Exp0
a'' Exp0 -> Exp0 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp0
b'') (PassM () -> PassM ()) -> PassM () -> PassM ()
forall a b. (a -> b) -> a -> b
$ String -> PassM ()
forall a. HasCallStack => String -> a
error (String -> PassM ()) -> String -> PassM ()
forall a b. (a -> b) -> a -> b
$ String
"Expected annotation on SymDict:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp0 -> String
forall a. Show a => a -> String
show Exp0
a''
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
DictEmptyP (Ty0 -> Prim Ty0) -> Ty0 -> Prim Ty0
forall a b. (a -> b) -> a -> b
$ Sexp -> Ty0
typ Sexp
ty) [Exp0
a']
       (Exp0, Exp0)
_ -> do
         Bool -> PassM () -> PassM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Exp0
a' Exp0 -> Exp0 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp0
b') (PassM () -> PassM ()) -> PassM () -> PassM ()
forall a b. (a -> b) -> a -> b
$ String -> PassM ()
forall a. HasCallStack => String -> a
error (String -> PassM ()) -> String -> PassM ()
forall a b. (a -> b) -> a -> b
$ String
"Expected annotation on SymDict:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp0 -> String
forall a. Show a => a -> String
show Exp0
a'
         Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
DictEmptyP (Ty0 -> Prim Ty0) -> Ty0 -> Prim Ty0
forall a b. (a -> b) -> a -> b
$ Sexp -> Ty0
typ Sexp
ty) [Exp0
a']

   Ls5 Location
l Text
"insert" Sexp
a Sexp
d Sexp
k (Ls3 Location
_ Text
"ann" Sexp
v Sexp
ty) -> do
     Exp0
a' <- Sexp -> PassM Exp0
exp Sexp
a
     Exp0
d' <- Sexp -> PassM Exp0
exp Sexp
d
     Exp0
k' <- Sexp -> PassM Exp0
exp Sexp
k
     Exp0
v' <- Sexp -> PassM Exp0
exp Sexp
v
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
DictInsertP (Ty0 -> Prim Ty0) -> Ty0 -> Prim Ty0
forall a b. (a -> b) -> a -> b
$ Sexp -> Ty0
typ Sexp
ty) [Exp0
a',Exp0
d',Exp0
k',Exp0
v']

   Ls3 Location
l Text
"ann" (Ls3 Location
_ Text
"lookup" Sexp
d Sexp
k) Sexp
ty -> do
     Exp0
d' <- Sexp -> PassM Exp0
exp Sexp
d
     Exp0
k' <- Sexp -> PassM Exp0
exp Sexp
k
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
DictLookupP (Ty0 -> Prim Ty0) -> Ty0 -> Prim Ty0
forall a b. (a -> b) -> a -> b
$ Sexp -> Ty0
typ Sexp
ty) [Exp0
d', Exp0
k']

   Ls3 Location
l Text
"ann" (Ls3  Location
_ Text
"has-key?" Sexp
d Sexp
k) Sexp
ty -> do
     Exp0
d' <- Sexp -> PassM Exp0
exp Sexp
d
     Exp0
k' <- Sexp -> PassM Exp0
exp Sexp
k
     Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
DictHasKeyP (Ty0 -> Prim Ty0) -> Ty0 -> Prim Ty0
forall a b. (a -> b) -> a -> b
$ Sexp -> Ty0
typ Sexp
ty) [Exp0
d', Exp0
k']

   -- L [A "error",arg] ->
   Ls3 Location
l Text
"ann" (Ls2 Location
_ Text
"error" Sexp
arg) Sexp
ty ->
     case Sexp
arg of
       G Location
_ (HSString Text
str) -> Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (String -> Ty0 -> Prim Ty0
forall ty. String -> ty -> Prim ty
ErrorP (Text -> String
T.unpack Text
str) (Sexp -> Ty0
typ Sexp
ty)) []
       Sexp
_ -> String -> PassM Exp0
forall a. HasCallStack => String -> a
error(String -> PassM Exp0) -> String -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ String
"bad argument to 'error' primitive: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
arg

   -- Other annotations are dropped:
   Ls3 Location
l Text
"ann" Sexp
e Sexp
_ty -> E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> PassM Exp0 -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sexp -> PassM Exp0
exp Sexp
e

   -- List operations
   Ls2 Location
l Text
"valloc" Sexp
i -> do
       Ty0
elty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
ie <- Sexp -> PassM Exp0
exp Sexp
i
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VAllocP Ty0
elty) [Exp0
ie]

   Ls2 Location
l Text
"vfree" Sexp
i -> do
       Ty0
elty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
ie <- Sexp -> PassM Exp0
exp Sexp
i
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VFreeP Ty0
elty) [Exp0
ie]

   Ls2 Location
l Text
"vfree2" Sexp
i -> do
       Ty0
elty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
ie <- Sexp -> PassM Exp0
exp Sexp
i
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VFree2P Ty0
elty) [Exp0
ie]

   Ls2 Location
l Text
"vlength" Sexp
ls -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
lse <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VLengthP Ty0
ty) [Exp0
lse]

   Ls3 Location
l Text
"vnth" Sexp
ls Sexp
i -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
lse <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0
ie <- Sexp -> PassM Exp0
exp Sexp
i
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VNthP Ty0
ty) [Exp0
lse, Exp0
ie]

   Ls4 Location
l Text
"vslice" Sexp
from Sexp
to Sexp
ls -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
frome <- Sexp -> PassM Exp0
exp Sexp
from
       Exp0
toe <- Sexp -> PassM Exp0
exp Sexp
to
       Exp0
lse  <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VSliceP Ty0
ty) [Exp0
frome,Exp0
toe,Exp0
lse]

   Ls4 Location
l Text
"inplacevupdate" Sexp
ls Sexp
i Sexp
v -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
lse <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0
ie <- Sexp -> PassM Exp0
exp Sexp
i
       Exp0
ve <- Sexp -> PassM Exp0
exp Sexp
v
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
InplaceVUpdateP Ty0
ty) [Exp0
lse,Exp0
ie,Exp0
ve]

   Ls2 Location
l Text
"vconcat" Sexp
ls -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
lse <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VConcatP Ty0
ty) [Exp0
lse]

   Ls3 Location
l Text
"vsort" Sexp
f Sexp
ls -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
fe  <- Sexp -> PassM Exp0
exp Sexp
f
       Exp0
lse <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VSortP Ty0
ty) [Exp0
fe,Exp0
lse]

   Ls3 Location
l Text
"inplacevsort" Sexp
f Sexp
ls -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
fe  <- Sexp -> PassM Exp0
exp Sexp
f
       Exp0
lse <- Sexp -> PassM Exp0
exp Sexp
ls
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
InplaceVSortP Ty0
ty) [Exp0
fe,Exp0
lse]

   Ls3 Location
l Text
"vmerge" Sexp
ls1 Sexp
ls2 -> do
       Ty0
ty <- PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy
       Exp0
ls1e <- Sexp -> PassM Exp0
exp Sexp
ls1
       Exp0
ls2e <- Sexp -> PassM Exp0
exp Sexp
ls2
       Exp0 -> PassM Exp0
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp0 -> PassM Exp0) -> Exp0 -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> E0Ext Ty0 Ty0
forall a b. (a -> b) -> a -> b
$ Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE (Ty0 -> Prim Ty0
forall ty. ty -> Prim ty
VMergeP Ty0
ty) [Exp0
ls1e,Exp0
ls2e]

   Ls (A Location
_ Text
kwd : [Sexp]
_args) | Text -> Bool
isKeyword Text
kwd ->
      String -> PassM Exp0
forall a. HasCallStack => String -> a
error (String -> PassM Exp0) -> String -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ String
"Error reading treelang. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
kwd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is a keyword:\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
se

   ----------------------------------------
   -- If NOTHING else matches, we are an application.  Be careful we didn't miss anything:
   Ls (A Location
l Text
rator : [Sexp]
rands) ->
     let app :: [Exp0] -> Exp0
app = Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE (Text -> Var
textToVar Text
rator) []
     in E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> (Exp0 -> E0Ext Ty0 Ty0) -> Exp0 -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L (Location -> Loc
toLoc Location
l) (Exp0 -> Exp0) -> ([Exp0] -> Exp0) -> [Exp0] -> Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp0] -> Exp0
app ([Exp0] -> Exp0) -> PassM [Exp0] -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sexp -> PassM Exp0) -> [Sexp] -> PassM [Exp0]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM Exp0
exp [Sexp]
rands

   Sexp
_ -> String -> PassM Exp0
forall a. HasCallStack => String -> a
error (String -> PassM Exp0) -> String -> PassM Exp0
forall a b. (a -> b) -> a -> b
$ String
"Expression form not handled (yet):\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++
               Sexp -> String
forall a. Show a => a -> String
show Sexp
se String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nMore concisely:\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sexp -> String
prnt Sexp
se


-- | One case of a case expression
docase :: Sexp -> PassM (DataCon,[(Var,Ty0)], Exp0)
docase :: Sexp -> PassM (String, [(Var, Ty0)], Exp0)
docase Sexp
s =
  case Sexp
s of
    RSList [ RSList (A Location
_ Text
con : [Sexp]
args)
           , Sexp
rhs ]
      -> do [(Var, Ty0)]
args' <- (Sexp -> PassM (Var, Ty0)) -> [Sexp] -> PassM [(Var, Ty0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Sexp -> PassM (Var, Ty0)
forall {f :: * -> *}. MonadState Int f => Sexp -> f (Var, Ty0)
f [Sexp]
args
            Exp0
rhs'  <- Sexp -> PassM Exp0
exp Sexp
rhs
            (String, [(Var, Ty0)], Exp0) -> PassM (String, [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
textToDataCon Text
con, [(Var, Ty0)]
args', Exp0
rhs')
    Sexp
_ -> String -> PassM (String, [(Var, Ty0)], Exp0)
forall a. HasCallStack => String -> a
error(String -> PassM (String, [(Var, Ty0)], Exp0))
-> String -> PassM (String, [(Var, Ty0)], Exp0)
forall a b. (a -> b) -> a -> b
$ String
"bad clause in case expression\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
s
 where
   f :: Sexp -> f (Var, Ty0)
f Sexp
x  = (Sexp -> Var
getSym Sexp
x, ) (Ty0 -> (Var, Ty0)) -> f Ty0 -> f (Var, Ty0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy

letbind :: Sexp -> PassM (Var,[l],Ty0, Exp0)
letbind :: forall l. Sexp -> PassM (Var, [l], Ty0, Exp0)
letbind Sexp
s =
  case Sexp
s of
   RSList [A Location
_ Text
vr, A Location
_ Text
":", Sexp
ty, Sexp
rhs] ->
     (Text -> Var
textToVar Text
vr, [], Sexp -> Ty0
typ Sexp
ty, ) (Exp0 -> (Var, [l], Ty0, Exp0))
-> PassM Exp0 -> PassM (Var, [l], Ty0, Exp0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sexp -> PassM Exp0
exp Sexp
rhs
   -- A let binding without a type annotation.
   RSList [A Location
_ Text
vr, Sexp
rhs] ->
     (Text -> Var
textToVar Text
vr, [], , ) (Ty0 -> Exp0 -> (Var, [l], Ty0, Exp0))
-> PassM Ty0 -> PassM (Exp0 -> (Var, [l], Ty0, Exp0))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassM Ty0
forall (m :: * -> *). MonadState Int m => m Ty0
newMetaTy PassM (Exp0 -> (Var, [l], Ty0, Exp0))
-> PassM Exp0 -> PassM (Var, [l], Ty0, Exp0)
forall a b. PassM (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sexp -> PassM Exp0
exp Sexp
rhs
   Sexp
_ -> String -> PassM (Var, [l], Ty0, Exp0)
forall a. HasCallStack => String -> a
error (String -> PassM (Var, [l], Ty0, Exp0))
-> String -> PassM (Var, [l], Ty0, Exp0)
forall a b. (a -> b) -> a -> b
$ String
"Badly formed let binding:\n  "String -> String -> String
forall a. [a] -> [a] -> [a]
++Sexp -> String
prnt Sexp
s

isPrim :: Text -> Bool
isPrim :: Text -> Bool
isPrim Text
p = Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Text
p (Map Text (Prim Any) -> Set Text
forall k a. Map k a -> Set k
M.keysSet Map Text (Prim Any)
forall d. Map Text (Prim d)
primMap)

-- ^ A map between SExp-frontend prefix function names, and Gibbon
-- abstract Primops.
primMap :: M.Map Text (Prim d)
primMap :: forall d. Map Text (Prim d)
primMap = [(Text, Prim d)] -> Map Text (Prim d)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Text
"+", Prim d
forall ty. Prim ty
AddP)
  , (Text
"-", Prim d
forall ty. Prim ty
SubP)
  , (Text
"*", Prim d
forall ty. Prim ty
MulP)
  , (Text
"div", Prim d
forall ty. Prim ty
DivP)
  , (Text
"mod", Prim d
forall ty. Prim ty
ModP)
  , (Text
"exp", Prim d
forall ty. Prim ty
ExpP)
  , (Text
"rand", Prim d
forall ty. Prim ty
RandP)
  , (Text
"eqsym", Prim d
forall ty. Prim ty
EqSymP)
  , (Text
"=", Prim d
forall ty. Prim ty
EqIntP)
  , (Text
"<", Prim d
forall ty. Prim ty
LtP)
  , (Text
">", Prim d
forall ty. Prim ty
GtP)
  , (Text
"<=", Prim d
forall ty. Prim ty
LtEqP)
  , (Text
">=", Prim d
forall ty. Prim ty
GtEqP)
  , (Text
"or" , Prim d
forall ty. Prim ty
OrP)
  , (Text
"and", Prim d
forall ty. Prim ty
AndP)
  , (Text
"size-param", Prim d
forall ty. Prim ty
SizeParam)
  , (Text
"True", Prim d
forall ty. Prim ty
MkTrue)
  , (Text
"False", Prim d
forall ty. Prim ty
MkFalse)
  , (Text
"gensym", Prim d
forall ty. Prim ty
Gensym)
  , (Text
"printint", Prim d
forall ty. Prim ty
PrintInt)
  , (Text
"printchar", Prim d
forall ty. Prim ty
PrintChar)
  , (Text
"printfloat", Prim d
forall ty. Prim ty
PrintFloat)
  , (Text
"printbool", Prim d
forall ty. Prim ty
PrintBool)
  , (Text
"printsym", Prim d
forall ty. Prim ty
PrintSym)
  , (Text
"readint", Prim d
forall ty. Prim ty
ReadInt)
  , (Text
"sym-set-empty", Prim d
forall ty. Prim ty
SymSetEmpty)
  , (Text
"sym-set-insert", Prim d
forall ty. Prim ty
SymSetInsert)
  , (Text
"sym-set-contains", Prim d
forall ty. Prim ty
SymSetContains)
  , (Text
"sym-hash-empty", Prim d
forall ty. Prim ty
SymHashEmpty)
  , (Text
"sym-hash-insert", Prim d
forall ty. Prim ty
SymHashInsert)
  , (Text
"sym-hash-lookup", Prim d
forall ty. Prim ty
SymHashLookup)
  , (Text
"sym-hash-contains", Prim d
forall ty. Prim ty
SymHashLookup)
  , (Text
"is-big", Prim d
forall ty. Prim ty
IsBig)
  ]

prim :: Text -> Prim Ty0
prim :: Text -> Prim Ty0
prim Text
t = case Text -> Map Text (Prim Ty0) -> Maybe (Prim Ty0)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t Map Text (Prim Ty0)
forall d. Map Text (Prim d)
primMap of
           Just Prim Ty0
x -> Prim Ty0
x
           Maybe (Prim Ty0)
Nothing -> String -> Prim Ty0
forall a. HasCallStack => String -> a
error(String -> Prim Ty0) -> String -> Prim Ty0
forall a b. (a -> b) -> a -> b
$ String
"Internal error, this is not a primitive: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
t


handleRequire :: FilePath -> [RichSExpr (SC.Located HaskLikeAtom)] ->
                 IO [RichSExpr (SC.Located HaskLikeAtom)]
handleRequire :: String -> [Sexp] -> IO [Sexp]
handleRequire String
_ [] = [Sexp] -> IO [Sexp]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
handleRequire String
baseFile (Sexp
l:[Sexp]
ls) =
  case Sexp
l of
    (RSList [RSAtom (SC.At Location
_ HaskLikeAtom
"require"), Sexp
arg]) -> do
    -- (Ls2 "require" arg) -> do
       [Sexp]
ls' <- String -> [Sexp] -> IO [Sexp]
handleRequire String
baseFile [Sexp]
ls
       let file :: String
file = case Sexp
arg of
                    RSAtom (SC.At Location
_ (HSString Text
str)) -> (String -> String
takeDirectory String
baseFile) String -> String -> String
</> (Text -> String
unpack Text
str)
                    Sexp
_ -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"bad require line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Sexp -> String
forall a. Show a => a -> String
show Sexp
arg)
       Int -> String -> IO ()
dbgPrintLn Int
lvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Including required file: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
file
       Text
txt <- (Text -> Text) -> IO Text -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
bracketHacks (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readFile String
file
       Int -> String -> IO ()
dbgPrintLn Int
lvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Parsing required text: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
txt
       let res :: Either String [RichSExpr (SC.Located HaskLikeAtom)]
           res :: Either String [Sexp]
res = ([SExpr (Located HaskLikeAtom)] -> [Sexp])
-> Either String [SExpr (Located HaskLikeAtom)]
-> Either String [Sexp]
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SExpr (Located HaskLikeAtom) -> Sexp)
-> [SExpr (Located HaskLikeAtom)] -> [Sexp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SExpr (Located HaskLikeAtom) -> Sexp
forall atom. SExpr atom -> RichSExpr atom
toRich) (Either String [SExpr (Located HaskLikeAtom)]
 -> Either String [Sexp])
-> Either String [SExpr (Located HaskLikeAtom)]
-> Either String [Sexp]
forall a b. (a -> b) -> a -> b
$
                 SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
-> Text -> Either String [SExpr (Located HaskLikeAtom)]
forall atom carrier.
SExprParser atom carrier -> Text -> Either String [carrier]
decode SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
treelangParser Text
txt
       case Either String [Sexp]
res of
         Left String
err -> String -> IO [Sexp]
forall a. HasCallStack => String -> a
error String
err
         -- Right ls -> return $ ls ++ ls'
         Right [Sexp]
l' -> [Sexp] -> IO [Sexp]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Sexp] -> IO [Sexp]) -> [Sexp] -> IO [Sexp]
forall a b. (a -> b) -> a -> b
$ [Sexp]
l' [Sexp] -> [Sexp] -> [Sexp]
forall a. [a] -> [a] -> [a]
++ [Sexp]
ls'
    Sexp
_ -> do
      [Sexp]
ls' <- String -> [Sexp] -> IO [Sexp]
handleRequire String
baseFile [Sexp]
ls
      [Sexp] -> IO [Sexp]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Sexp] -> IO [Sexp]) -> [Sexp] -> IO [Sexp]
forall a b. (a -> b) -> a -> b
$ Sexp
lSexp -> [Sexp] -> [Sexp]
forall a. a -> [a] -> [a]
:[Sexp]
ls'

-- ^ Parse a file to an L1 program.  Return also the gensym counter.
parseFile :: FilePath -> IO (PassM Prog0)
parseFile :: String -> IO (PassM Prog0)
parseFile String
file = do
  Text
txt    <- (Text -> Text) -> IO Text -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
bracketHacks (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$
            -- fmap stripHashLang $
            String -> IO Text
readFile String
file
  Int -> String -> IO ()
dbgPrintLn Int
lvl (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Parsing text: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
txt
  let res :: Either String [RichSExpr (SC.Located HaskLikeAtom)]
      res :: Either String [Sexp]
res = ([SExpr (Located HaskLikeAtom)] -> [Sexp])
-> Either String [SExpr (Located HaskLikeAtom)]
-> Either String [Sexp]
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SExpr (Located HaskLikeAtom) -> Sexp)
-> [SExpr (Located HaskLikeAtom)] -> [Sexp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SExpr (Located HaskLikeAtom) -> Sexp
forall atom. SExpr atom -> RichSExpr atom
toRich) (Either String [SExpr (Located HaskLikeAtom)]
 -> Either String [Sexp])
-> Either String [SExpr (Located HaskLikeAtom)]
-> Either String [Sexp]
forall a b. (a -> b) -> a -> b
$
            SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
-> Text -> Either String [SExpr (Located HaskLikeAtom)]
forall atom carrier.
SExprParser atom carrier -> Text -> Either String [carrier]
decode SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
treelangParser Text
txt
  Int -> String -> IO ()
dbgPrintLn Int
lvl String
"Result of parsing:"
  case Either String [Sexp]
res of
     Left String
err -> String -> IO (PassM Prog0)
forall a. HasCallStack => String -> a
error String
err
     Right [Sexp]
ls -> do
       [Sexp]
ls' <- String -> [Sexp] -> IO [Sexp]
handleRequire String
file [Sexp]
ls
       PassM Prog0 -> IO (PassM Prog0)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PassM Prog0 -> IO (PassM Prog0))
-> PassM Prog0 -> IO (PassM Prog0)
forall a b. (a -> b) -> a -> b
$ [Sexp] -> PassM Prog0
parseSExp [Sexp]
ls'