{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Safe #-}
-- | Parser for the Hyle concrete syntax (doc/hyle.md, section 10).
--
--   The concrete syntax does not carry per-node widths, so parsing is
--   followed by an elaboration pass that reconstructs the cached sizes
--   bottom-up: variable sizes from binders, call result sizes from the
--   signatures of the named defns and externs. Full well-formedness checking
--   (ReWire.Hyle.Check) is separate; elaboration only fails where a size
--   cannot be reconstructed at all.
module ReWire.Hyle.Parse (parseHyle, parseHyleText, parseHyleDefns) where

import ReWire.Annotation (Annote, noAnn, srcAnnote)
import ReWire.BitVector (BV, bitVec)
import ReWire.Error (failAt, MonadError, AstError)
import ReWire.Hyle.Syntax
import ReWire.Pretty (showt)

import Control.Monad (unless, when, foldM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Char (isAlpha, isAlphaNum)
import Data.Functor (void)
import Data.HashMap.Strict (HashMap)
import Data.Text (Text, pack)
import Data.Void (Void)
import Numeric.Natural (Natural)
import Text.Megaparsec (Parsec, ParseErrorBundle, many, try, (<|>), (<?>), manyTill, parse, between, sepBy, sepBy1, notFollowedBy, option, optional, satisfy, eof, empty, chunk, oneOf, takeWhileP, getSourcePos, attachSourcePos, errorOffset, bundleErrors, bundlePosState, parseErrorTextPretty)
import Text.Megaparsec.Char (char, space1)
import Text.Megaparsec.Pos (SourcePos (..), unPos)
import Text.Read (readMaybe)

import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet        as Set
import qualified Data.List.NonEmpty  as NE
import qualified Data.Text           as T
import qualified Data.Text.IO        as T
import qualified Text.Megaparsec.Char.Lexer as L

type Parser = Parsec Void Text

parseHyle :: (MonadError AstError m, MonadIO m) => FilePath -> m Program
parseHyle :: forall (m :: * -> *).
(MonadError AstError m, MonadIO m) =>
String -> m Program
parseHyle String
p = IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
T.readFile String
p) m Text -> (Text -> m Program) -> m Program
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> String -> m Program) -> String -> Text -> m Program
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> String -> m Program
forall (m :: * -> *).
MonadError AstError m =>
Text -> String -> m Program
parseHyleText String
p

parseHyleText :: MonadError AstError m => Text -> FilePath -> m Program
parseHyleText :: forall (m :: * -> *).
MonadError AstError m =>
Text -> String -> m Program
parseHyleText Text
txt String
p = (ParseErrorBundle Text Void -> m Program)
-> (Program -> m Program)
-> Either (ParseErrorBundle Text Void) Program
-> m Program
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle Text Void -> m Program
forall (m :: * -> *) a.
MonadError AstError m =>
ParseErrorBundle Text Void -> m a
failParse Program -> m Program
forall (m :: * -> *). MonadError AstError m => Program -> m Program
elabProgram (Either (ParseErrorBundle Text Void) Program -> m Program)
-> Either (ParseErrorBundle Text Void) Program -> m Program
forall a b. (a -> b) -> a -> b
$ Parsec Void Text Program
-> String -> Text -> Either (ParseErrorBundle Text Void) Program
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser ()
space Parser () -> Parsec Void Text Program -> Parsec Void Text Program
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Program
program Parsec Void Text Program -> Parser () -> Parsec Void Text Program
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
p Text
txt

-- | Parse a defns-only Hyle fragment (no device declaration): the
--   interchange format for definitions generated outside the fold (the
--   rwcry Cryptol translator). The fragment must be self-contained --
--   elaboration resolves calls against the fragment's own definitions
--   (and externs, if any) only.
parseHyleDefns :: MonadError AstError m => Text -> FilePath -> m [Defn]
parseHyleDefns :: forall (m :: * -> *).
MonadError AstError m =>
Text -> String -> m [Defn]
parseHyleDefns Text
txt String
p = (ParseErrorBundle Text Void -> m [Defn])
-> ([Decl] -> m [Defn])
-> Either (ParseErrorBundle Text Void) [Decl]
-> m [Defn]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle Text Void -> m [Defn]
forall (m :: * -> *) a.
MonadError AstError m =>
ParseErrorBundle Text Void -> m a
failParse [Decl] -> m [Defn]
forall (m :: * -> *). MonadError AstError m => [Decl] -> m [Defn]
elab (Either (ParseErrorBundle Text Void) [Decl] -> m [Defn])
-> Either (ParseErrorBundle Text Void) [Decl] -> m [Defn]
forall a b. (a -> b) -> a -> b
$ Parsec Void Text [Decl]
-> String -> Text -> Either (ParseErrorBundle Text Void) [Decl]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser ()
space Parser () -> Parsec Void Text [Decl] -> Parsec Void Text [Decl]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Decl -> Parsec Void Text [Decl]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Decl
decl Parsec Void Text [Decl] -> Parser () -> Parsec Void Text [Decl]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
p Text
txt
      where elab :: MonadError AstError m => [Decl] -> m [Defn]
            elab :: forall (m :: * -> *). MonadError AstError m => [Decl] -> m [Defn]
elab [Decl]
ds = (Defn -> m Defn) -> [Defn] -> m [Defn]
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 (SigEnv -> Defn -> m Defn
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> Defn -> m Defn
elabDefn SigEnv
env) [Defn]
defns
                  where defns :: [Defn]
defns = [ Defn
d | DDefn Defn
d <- [Decl]
ds ]
                        env :: SigEnv
env   = HashMap Text Sig -> HashMap Text Extern -> SigEnv
SigEnv ([(Text, Sig)] -> HashMap Text Sig
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Sig)] -> HashMap Text Sig)
-> [(Text, Sig)] -> HashMap Text Sig
forall a b. (a -> b) -> a -> b
$ (Defn -> (Text, Sig)) -> [Defn] -> [(Text, Sig)]
forall a b. (a -> b) -> [a] -> [b]
map (\ Defn
d -> (Defn -> Text
defnName Defn
d, Defn -> Sig
defnSig Defn
d)) [Defn]
defns)
                                       ([(Text, Extern)] -> HashMap Text Extern
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [ (Extern -> Text
extName Extern
e, Extern
e) | DExtern Extern
e <- [Decl]
ds ])

failParse :: MonadError AstError m => ParseErrorBundle Text Void -> m a
failParse :: forall (m :: * -> *) a.
MonadError AstError m =>
ParseErrorBundle Text Void -> m a
failParse ParseErrorBundle Text Void
bundle = Annote -> Text -> m a
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (String -> (Int, Int) -> (Int, Int) -> Annote
srcAnnote (SourcePos -> String
sourceName SourcePos
pos) (SourcePos -> (Int, Int)
lc SourcePos
pos) (SourcePos -> (Int, Int)
lc SourcePos
pos)) (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseError Text Void -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty ParseError Text Void
e)
      where (ParseError Text Void
e, SourcePos
pos) = NonEmpty (ParseError Text Void, SourcePos)
-> (ParseError Text Void, SourcePos)
forall a. NonEmpty a -> a
NE.head (NonEmpty (ParseError Text Void, SourcePos)
 -> (ParseError Text Void, SourcePos))
-> NonEmpty (ParseError Text Void, SourcePos)
-> (ParseError Text Void, SourcePos)
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
-> NonEmpty (ParseError Text Void, SourcePos)
forall a b. (a, b) -> a
fst ((NonEmpty (ParseError Text Void, SourcePos), PosState Text)
 -> NonEmpty (ParseError Text Void, SourcePos))
-> (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
-> NonEmpty (ParseError Text Void, SourcePos)
forall a b. (a -> b) -> a -> b
$ (ParseError Text Void -> Int)
-> NonEmpty (ParseError Text Void)
-> PosState Text
-> (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
attachSourcePos ParseError Text Void -> Int
forall s e. ParseError s e -> Int
errorOffset (ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors ParseErrorBundle Text Void
bundle) (ParseErrorBundle Text Void -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
bundlePosState ParseErrorBundle Text Void
bundle)
            lc :: SourcePos -> (Int, Int)
lc SourcePos
sp = (Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
sp, Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
sp)

---
--- Raw parsing. Sizes that aren't manifest in the syntax are filled with 0
--- and reconstructed by elaboration below.
---

data Decl = DExtern Extern | DDefn Defn | DDevice Device

program :: Parser Program
program :: Parsec Void Text Program
program = do
      ds <- ParsecT Void Text Identity Decl -> Parsec Void Text [Decl]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Decl
decl
      case [ d | DDevice d <- ds ] of
            [Device
dev] -> Program -> Parsec Void Text Program
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Program -> Parsec Void Text Program)
-> Program -> Parsec Void Text Program
forall a b. (a -> b) -> a -> b
$ [Extern] -> [Defn] -> Device -> Program
Program [ Extern
e | DExtern Extern
e <- [Decl]
ds ] [ Defn
d | DDefn Defn
d <- [Decl]
ds ] Device
dev
            []    -> String -> Parsec Void Text Program
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no device declaration"
            [Device]
_     -> String -> Parsec Void Text Program
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"multiple device declarations"

decl :: Parser Decl
decl :: ParsecT Void Text Identity Decl
decl = Extern -> Decl
DExtern (Extern -> Decl)
-> ParsecT Void Text Identity Extern
-> ParsecT Void Text Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Extern
extern
   ParsecT Void Text Identity Decl
-> ParsecT Void Text Identity Decl
-> ParsecT Void Text Identity Decl
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Device -> Decl
DDevice (Device -> Decl)
-> ParsecT Void Text Identity Device
-> ParsecT Void Text Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Device
device
   ParsecT Void Text Identity Decl
-> ParsecT Void Text Identity Decl
-> ParsecT Void Text Identity Decl
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Defn -> Decl
DDefn   (Defn -> Decl)
-> ParsecT Void Text Identity Defn
-> ParsecT Void Text Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Defn
defn
   ParsecT Void Text Identity Decl
-> String -> ParsecT Void Text Identity Decl
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"declaration (extern, device, or definition)"

extern :: Parser Extern
extern :: ParsecT Void Text Identity Extern
extern = do
      Text -> Parser ()
keyword Text
"extern"
      n    <- Parser Text
name
      gs   <- option' [] $ keyword "generic" *> (name `sepBy1` comma)
      clk  <- optional $ try $ keyword "clock" *> name
      rst  <- optional $ try $ keyword "reset" *> name
      ins  <- many $ try $ keyword "input"  *> port
      outs <- many $ try $ keyword "output" *> port
      m    <- optional $ try $ keyword "model" *> name
      let k = case (Maybe Text
clk, Maybe Text
rst) of
            (Maybe Text
Nothing, Maybe Text
Nothing) -> ExternKind
Comb
            (Maybe Text, Maybe Text)
_                  -> Maybe Text -> Maybe Text -> ExternKind
Seq Maybe Text
clk Maybe Text
rst
      pure $ Extern noAnn n gs k ins outs m
      ParsecT Void Text Identity Extern
-> String -> ParsecT Void Text Identity Extern
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"extern declaration"
      where option' :: a -> Parser a -> Parser a
            option' :: forall a. a -> Parser a -> Parser a
option' a
x Parser a
p = Parser a -> Parser a
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser a
p Parser a -> Parser a -> Parser a
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Parser a
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

port :: Parser (Name, Size)
port :: ParsecT Void Text Identity (Text, Size)
port = (,) (Text -> Size -> (Text, Size))
-> Parser Text -> ParsecT Void Text Identity (Size -> (Text, Size))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
name ParsecT Void Text Identity (Size -> (Text, Size))
-> ParsecT Void Text Identity Size
-> ParsecT Void Text Identity (Text, Size)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
colon Parser ()
-> ParsecT Void Text Identity Size
-> ParsecT Void Text Identity Size
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Size
ty)

ty :: Parser Size
ty :: ParsecT Void Text Identity Size
ty = ParsecT Void Text Identity Size -> ParsecT Void Text Identity Size
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
brackets ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal ParsecT Void Text Identity Size
-> String -> ParsecT Void Text Identity Size
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"type"

defn :: Parser Defn
defn :: ParsecT Void Text Identity Defn
defn = do
      an   <- Annote
-> ParsecT Void Text Identity Annote
-> ParsecT Void Text Identity Annote
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Annote
noAnn ParsecT Void Text Identity Annote
spanLine
      docs <- many docLine
      n    <- name
      sig  <- colon *> (Sig noAnn <$> parens (ty `sepBy` comma) <*> (arrow *> ty))
      ni   <- option False $ True <$ keyword "noinline"
      n'   <- name
      unless (n == n') $ fail "definition name does not match its signature"
      ps   <- many name
      e    <- equals *> expr
      pure $ Defn an n sig ps e ni $ Blind docs
      ParsecT Void Text Identity Defn
-> String -> ParsecT Void Text Identity Defn
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"definition"

device :: Parser Device
device :: ParsecT Void Text Identity Device
device = do
      Text -> Parser ()
keyword Text
"device"
      n     <- Parser Text
name
      ins   <- many $ try $ keyword "input"  *> port
      outs  <- many $ try $ keyword "output" *> port
      regs  <- many $ try register
      tags  <- many $ try tagLine
      insts <- many $ try inst
      body  <- many stmt
      pure $ Device noAnn n ins outs regs insts body $ Blind tags
      ParsecT Void Text Identity Device
-> String -> ParsecT Void Text Identity Device
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"device declaration"

register :: Parser Register
register :: ParsecT Void Text Identity Register
register = do
      an      <- Annote
-> ParsecT Void Text Identity Annote
-> ParsecT Void Text Identity Annote
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Annote
noAnn ParsecT Void Text Identity Annote
spanLine
      keyword "register"
      (x, sz) <- port
      bv      <- keyword "init" *> lit
      pure $ Register an x sz bv

-- | A display name for one of the '__resumption_tag' register's values:
--   @tag \<name\> = \<value\>@.
tagLine :: Parser (Name, Integer)
tagLine :: ParsecT Void Text Identity (Text, Integer)
tagLine = (,) (Text -> Integer -> (Text, Integer))
-> Parser Text
-> ParsecT Void Text Identity (Integer -> (Text, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
keyword Text
"tag" Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
name) ParsecT Void Text Identity (Integer -> (Text, Integer))
-> ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity (Text, Integer)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
equals Parser ()
-> ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Integer
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Integer
forall a. Num a => Parser a
decimal)

inst :: Parser Instance
inst :: ParsecT Void Text Identity Instance
inst = Parser (Annote -> Instance) -> ParsecT Void Text Identity Instance
forall a. Parser (Annote -> a) -> Parser a
withSpan (Parser (Annote -> Instance)
 -> ParsecT Void Text Identity Instance)
-> Parser (Annote -> Instance)
-> ParsecT Void Text Identity Instance
forall a b. (a -> b) -> a -> b
$ do
      Text -> Parser ()
keyword Text
"instance"
      x  <- Parser Text
name
      ex <- keyword "of" *> name
      cs <- generics
      pure $ \ Annote
an -> Annote -> Text -> Text -> [Natural] -> Instance
Instance Annote
an Text
x Text
ex [Natural]
cs

stmt :: Parser Stmt
stmt :: ParsecT Void Text Identity Stmt
stmt = (Annote -> Text -> Exp -> Stmt
SLet Annote
noAnn (Text -> Exp -> Stmt)
-> Parser Text -> ParsecT Void Text Identity (Exp -> Stmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
keyword Text
"let" Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
name) ParsecT Void Text Identity (Exp -> Stmt)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Stmt
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
equals Parser ()
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Exp
expr))
   ParsecT Void Text Identity Stmt
-> ParsecT Void Text Identity Stmt
-> ParsecT Void Text Identity Stmt
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Annote -> Text -> Exp -> Stmt
SNext Annote
noAnn (Text -> Exp -> Stmt)
-> Parser Text -> ParsecT Void Text Identity (Exp -> Stmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
keyword Text
"next" Parser () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
name) ParsecT Void Text Identity (Exp -> Stmt)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Stmt
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
assign Parser ()
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Exp
expr))
   ParsecT Void Text Identity Stmt
-> ParsecT Void Text Identity Stmt
-> ParsecT Void Text Identity Stmt
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
            x <- Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Parser Text
name Parser Text -> Parser () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
assign
            e <- expr
            -- A dotted target is an instance input port. (Device-local
            -- names may not contain dots; see ReWire.Hyle.Check.)
            case T.breakOn "." x of
                  (Text
i, Text -> Text -> Maybe Text
T.stripPrefix Text
"." -> Just Text
p) | Bool -> Bool
not (Text -> Bool
T.null Text
p) -> Stmt -> ParsecT Void Text Identity Stmt
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt -> ParsecT Void Text Identity Stmt)
-> Stmt -> ParsecT Void Text Identity Stmt
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> Text -> Exp -> Stmt
SInstIn Annote
noAnn Text
i Text
p Exp
e
                  (Text, Text)
_                                                 -> Stmt -> ParsecT Void Text Identity Stmt
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt -> ParsecT Void Text Identity Stmt)
-> Stmt -> ParsecT Void Text Identity Stmt
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> Exp -> Stmt
SOutput Annote
noAnn Text
x Exp
e
   ParsecT Void Text Identity Stmt
-> String -> ParsecT Void Text Identity Stmt
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"statement"

---
--- Expressions.
---

expr :: Parser Exp
expr :: ParsecT Void Text Identity Exp
expr = ParsecT Void Text Identity Exp
letE ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Exp
ifE ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Exp
catE
      ParsecT Void Text Identity Exp
-> String -> ParsecT Void Text Identity Exp
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expression"

letE :: Parser Exp
letE :: ParsecT Void Text Identity Exp
letE = do
      Text -> Parser ()
keyword Text
"let"
      x  <- Parser Text
name
      e1 <- equals *> expr
      e2 <- keyword "in" *> expr
      pure $ Let noAnn 0 x e1 e2

ifE :: Parser Exp
ifE :: ParsecT Void Text Identity Exp
ifE = do
      Text -> Parser ()
keyword Text
"if"
      c <- ParsecT Void Text Identity Exp
expr
      t <- keyword "then" *> expr
      e <- keyword "else" *> expr
      pure $ If noAnn 0 c t e

catE :: Parser Exp
catE :: ParsecT Void Text Identity Exp
catE = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Annote -> Exp -> Exp -> Exp
Cat Annote
noAnn) ([Exp] -> Exp)
-> ParsecT Void Text Identity [Exp]
-> ParsecT Void Text Identity Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Exp
appE ParsecT Void Text Identity Exp
-> Parser Text -> ParsecT Void Text Identity [Exp]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Text -> Parser Text
symbol Text
"#"

appE :: Parser Exp
appE :: ParsecT Void Text Identity Exp
appE = ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Exp
primE ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Exp
callE ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Exp
atomE
      ParsecT Void Text Identity Exp
-> String -> ParsecT Void Text Identity Exp
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"application"

primE :: Parser Exp
primE :: ParsecT Void Text Identity Exp
primE = do
      op <- Parser Op
primOp
      es <- many atomE
      pure $ Prim noAnn 0 op es

-- | Operator names are reserved words, so this never collides with 'name'.
primOp :: Parser Op
primOp :: Parser Op
primOp = [(Text, Parser Op)] -> Parser Op
choiceOps
      [ (Text
"zext" , Size -> Op
ZExt  (Size -> Op) -> ParsecT Void Text Identity Size -> Parser Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal)
      , (Text
"sext" , Size -> Op
SExt  (Size -> Op) -> ParsecT Void Text Identity Size -> Parser Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal)
      , (Text
"trunc", Size -> Op
Trunc (Size -> Op) -> ParsecT Void Text Identity Size -> Parser Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal)
      , (Text
"rep"  , Natural -> Op
Rep   (Natural -> Op) -> ParsecT Void Text Identity Natural -> Parser Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Natural
forall a. Num a => Parser a
decimal)
      ] Parser Op -> Parser Op -> Parser Op
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Text, Parser Op)] -> Parser Op
choiceOps ((Op -> (Text, Parser Op)) -> [Op] -> [(Text, Parser Op)]
forall a b. (a -> b) -> [a] -> [b]
map (\ Op
op -> (Op -> Text
opName Op
op, Op -> Parser Op
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
op)) [Op]
nullaryOps)
      where choiceOps :: [(Text, Parser Op)] -> Parser Op
            choiceOps :: [(Text, Parser Op)] -> Parser Op
choiceOps = ((Text, Parser Op) -> Parser Op -> Parser Op)
-> Parser Op -> [(Text, Parser Op)] -> Parser Op
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Text
k, Parser Op
p) Parser Op
acc -> Parser Op -> Parser Op
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Text -> Parser ()
keyword Text
k Parser () -> Parser Op -> Parser Op
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Op
p) Parser Op -> Parser Op -> Parser Op
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Op
acc) Parser Op
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty

            nullaryOps :: [Op]
            nullaryOps :: [Op]
nullaryOps =
                  [ Op
Add, Op
Sub, Op
Mul, Op
UDiv, Op
UMod, Op
Pow, Op
And, Op
Or, Op
XOr, Op
Not
                  , Op
Shl, Op
LShr, Op
AShr
                  , Op
Eq, Op
Ne, Op
ULt, Op
ULe, Op
UGt, Op
UGe, Op
SLt, Op
SLe, Op
SGt, Op
SGe
                  , Op
RedAnd, Op
RedOr, Op
RedXOr
                  ]

-- | A name applied to generics and/or arguments. Resolved by elaboration
--   into a defn call, an extern call, or (when there are no arguments) a
--   variable reference.
callE :: Parser Exp
callE :: ParsecT Void Text Identity Exp
callE = do
      n  <- Parser Text
name
      cs <- generics
      es <- many atomE
      when (null cs && null es) $ fail "bare name parses as an atom" -- defer to atomE
      pure $ if null cs then Call noAnn 0 n es else XCall noAnn 0 n cs es

atomE :: Parser Exp
atomE :: ParsecT Void Text Identity Exp
atomE = do
      a  <- ParsecT Void Text Identity Exp
atomBase
      foldl' (\ Exp
e (Annote
an, Size
i, Size
k) -> Annote -> Size -> Size -> Exp -> Exp
Slice Annote
an Size
i Size
k Exp
e) a <$> many sliceSuffix
      where sliceSuffix :: Parser (Annote, Index, Size)
            sliceSuffix :: ParsecT Void Text Identity (Annote, Size, Size)
sliceSuffix = Parser (Annote -> (Annote, Size, Size))
-> ParsecT Void Text Identity (Annote, Size, Size)
forall a. Parser (Annote -> a) -> Parser a
withSpan (Parser (Annote -> (Annote, Size, Size))
 -> ParsecT Void Text Identity (Annote, Size, Size))
-> Parser (Annote -> (Annote, Size, Size))
-> ParsecT Void Text Identity (Annote, Size, Size)
forall a b. (a -> b) -> a -> b
$ Parser (Annote -> (Annote, Size, Size))
-> Parser (Annote -> (Annote, Size, Size))
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
brackets (Parser (Annote -> (Annote, Size, Size))
 -> Parser (Annote -> (Annote, Size, Size)))
-> Parser (Annote -> (Annote, Size, Size))
-> Parser (Annote -> (Annote, Size, Size))
forall a b. (a -> b) -> a -> b
$ (\ Size
i Size
k Annote
an -> (Annote
an, Size
i, Size
k)) (Size -> Size -> Annote -> (Annote, Size, Size))
-> ParsecT Void Text Identity Size
-> ParsecT
     Void Text Identity (Size -> Annote -> (Annote, Size, Size))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal ParsecT Void Text Identity (Size -> Annote -> (Annote, Size, Size))
-> ParsecT Void Text Identity Size
-> Parser (Annote -> (Annote, Size, Size))
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
symbol Text
"+:" Parser Text
-> ParsecT Void Text Identity Size
-> ParsecT Void Text Identity Size
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal)

atomBase :: Parser Exp
atomBase :: ParsecT Void Text Identity Exp
atomBase = Annote -> BV -> Exp
Lit Annote
noAnn (BV -> Exp)
-> ParsecT Void Text Identity BV -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity BV
lit
       ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Annote -> Size -> Exp
Undef Annote
noAnn (Size -> Exp)
-> ParsecT Void Text Identity Size
-> ParsecT Void Text Identity Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
keyword Text
"undef" Parser ()
-> ParsecT Void Text Identity Size
-> ParsecT Void Text Identity Size
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal)
       -- A name followed by ":" is not an atom: it is the target of an
       -- assignment statement or the start of the next definition. (The
       -- expression grammar itself has no ":".)
       ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Annote -> Size -> Text -> Exp
Var Annote
noAnn Size
0 (Text -> Exp) -> Parser Text -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text
name Parser Text -> Parser () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Text -> Parser Text
symbol Text
":"))) -- possibly a 0-ary defn call; elaboration resolves
       ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Exp -> ParsecT Void Text Identity Exp
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
parens ParsecT Void Text Identity Exp
expr
       ParsecT Void Text Identity Exp
-> String -> ParsecT Void Text Identity Exp
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"atom"

generics :: Parser [Natural]
generics :: Parser [Natural]
generics = (Text -> Parser Text
symbol Text
"<" Parser Text -> Parser [Natural] -> Parser [Natural]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void Text Identity Natural
forall a. Num a => Parser a
decimal ParsecT Void Text Identity Natural -> Parser () -> Parser [Natural]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser ()
comma) Parser [Natural] -> Parser Text -> Parser [Natural]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
symbol Text
">") Parser [Natural] -> Parser [Natural] -> Parser [Natural]
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Natural] -> Parser [Natural]
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

lit :: Parser BV
lit :: ParsecT Void Text Identity BV
lit = do
      w <- ParsecT Void Text Identity Size -> ParsecT Void Text Identity Size
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Size
 -> ParsecT Void Text Identity Size)
-> ParsecT Void Text Identity Size
-> ParsecT Void Text Identity Size
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Size
forall a. Num a => Parser a
decimal ParsecT Void Text Identity Size
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Size
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\''
      v <- (char 'h' *> L.hexadecimal) <|> pure 0
      notFollowedBy identChar
      space
      when ((v :: Integer) >= 2 ^ (w :: Size)) $
            fail $ "literal value does not fit in " <> show w <> " bits"
      pure $ bitVec (fromIntegral w) v
      ParsecT Void Text Identity BV
-> String -> ParsecT Void Text Identity BV
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"literal"

---
--- Lexing.
---

-- | Skips plain '--' line comments, but not the metadata channels '--|'
--   (doc lines) and '--@' (source locators), which are parsed as lexemes at
--   declaration boundaries ('docLine', 'spanLine').
space :: Parser ()
space :: Parser ()
space = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space (Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1) Parser ()
lineComment Parser ()
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty
      where lineComment :: Parser ()
            lineComment :: Parser ()
lineComment = ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"--" ParsecT Void Text Identity (Tokens Text)
-> Parser () -> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity (Token Text) -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ([Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (String
"|@" :: String)))
                        ParsecT Void Text Identity (Tokens Text) -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"character") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n'))

lexeme :: Parser a -> Parser a
lexeme :: forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme = Parser ()
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
space

symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = Parser ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
space

-- | A '--@ file:l:c-l:c' source-locator comment, parsed into a 'FromSource'
--   annotation that the printer re-renders byte-identically. The file part
--   may itself contain colons, so the four position fields are split off
--   from the right.
spanLine :: Parser Annote
spanLine :: ParsecT Void Text Identity Annote
spanLine = ParsecT Void Text Identity Annote
-> ParsecT Void Text Identity Annote
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme (ParsecT Void Text Identity Annote
 -> ParsecT Void Text Identity Annote)
-> ParsecT Void Text Identity Annote
-> ParsecT Void Text Identity Annote
forall a b. (a -> b) -> a -> b
$ do
      ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text) -> Parser ())
-> ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"--@"
      ParsecT Void Text Identity (Maybe Char) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe Char) -> Parser ())
-> ParsecT Void Text Identity (Maybe Char) -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity (Maybe Char))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
' '
      txt <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"character") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n')
      maybe (fail $ "malformed source locator (expected file:line:col-line:col): " <> T.unpack txt) pure
            $ parseSpan txt
      where parseSpan :: Text -> Maybe Annote
            parseSpan :: Text -> Maybe Annote
parseSpan Text
txt = do
                  (rest1, c2) <- Char -> Text -> Maybe (Text, Text)
breakOnLast Char
':' Text
txt
                  (rest2, cl) <- breakOnLast ':' rest1
                  (f, l1)     <- breakOnLast ':' rest2
                  (c1, l2)    <- breakOnFirst '-' cl
                  srcAnnote (T.unpack f) <$> ((,) <$> readInt l1 <*> readInt c1)
                                         <*> ((,) <$> readInt l2 <*> readInt c2)

            breakOnLast :: Char -> Text -> Maybe (Text, Text)
            breakOnLast :: Char -> Text -> Maybe (Text, Text)
breakOnLast Char
c Text
t = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd (Char -> Text
T.singleton Char
c) Text
t of
                  (Text
pre, Text
post) | Bool -> Bool
not (Text -> Bool
T.null Text
pre) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Int -> Text -> Text
T.dropEnd Int
1 Text
pre, Text
post)
                  (Text, Text)
_                              -> Maybe (Text, Text)
forall a. Maybe a
Nothing

            breakOnFirst :: Char -> Text -> Maybe (Text, Text)
            breakOnFirst :: Char -> Text -> Maybe (Text, Text)
breakOnFirst Char
c Text
t = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn (Char -> Text
T.singleton Char
c) Text
t of
                  (Text
pre, Text -> Text -> Maybe Text
T.stripPrefix (Char -> Text
T.singleton Char
c) -> Just Text
post) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
pre, Text
post)
                  (Text, Text)
_                                                 -> Maybe (Text, Text)
forall a. Maybe a
Nothing

            readInt :: Text -> Maybe Int
            readInt :: Text -> Maybe Int
readInt = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- | A '--| \<text\>' doc-comment line (the text after "--| ", raw, to the end
--   of the line).
docLine :: Parser Text
docLine :: Parser Text
docLine = Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
      ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text) -> Parser ())
-> ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"--|"
      ParsecT Void Text Identity (Maybe Char) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe Char) -> Parser ())
-> ParsecT Void Text Identity (Maybe Char) -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity (Maybe Char))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
' '
      Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"character") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n')

-- | Run a parser that builds a node from an annotation, supplying it the source
--   span the parser consumed so the node carries a real source location.
withSpan :: Parser (Annote -> a) -> Parser a
withSpan :: forall a. Parser (Annote -> a) -> Parser a
withSpan Parser (Annote -> a)
p = do
      s <- ParsecT Void Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
      f <- p
      e <- getSourcePos
      pure $ f $ srcAnnote (sourceName s) (pos s) (pos e)
      where pos :: SourcePos -> (Int, Int)
pos SourcePos
sp = (Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
sp, Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
sp)

keyword :: Text -> Parser ()
keyword :: Text -> Parser ()
keyword Text
k = Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
string' Text
k Parser () -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Char
identChar
      where string' :: Text -> Parser ()
            string' :: Text -> Parser ()
string' = (Char -> ParsecT Void Text Identity Char) -> String -> Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Char -> ParsecT Void Text Identity Char
Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char (String -> Parser ()) -> (Text -> String) -> Text -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

identStartChar :: Parser Char
identStartChar :: ParsecT Void Text Identity Char
identStartChar = (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall a b. (a -> b) -> a -> b
$ \ Token Text
c -> Char -> Bool
isAlpha Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$'

identChar :: Parser Char
identChar :: ParsecT Void Text Identity Char
identChar = (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall a b. (a -> b) -> a -> b
$ \ Token Text
c -> Char -> Bool
isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"_.$'" :: String)

name :: Parser Name
name :: Parser Text
name = Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme (Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Text
bare) Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
quoted
      Parser Text -> String -> Parser Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"name"
      where bare :: Parser Name
            bare :: Parser Text
bare = do
                  c  <- ParsecT Void Text Identity Char
identStartChar
                  cs <- many identChar
                  let x = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
                  when (x `Set.member` reservedWords) $ fail "reserved word"
                  pure x

            quoted :: Parser Name
            quoted :: Parser Text
quoted = Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"' ParsecT Void Text Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Text
pack (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"'))

colon, comma, arrow, equals, assign :: Parser ()
colon :: Parser ()
colon  = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
":"
comma :: Parser ()
comma  = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
","
arrow :: Parser ()
arrow  = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"->"
equals :: Parser ()
equals = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"="
assign :: Parser ()
assign = Parser Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser ()) -> Parser Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
":="

parens, brackets :: Parser a -> Parser a
parens :: forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
parens   = Parser Text
-> Parser Text
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"(") (Parser Text
 -> ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> Parser Text
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
")"
brackets :: forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
brackets = Parser Text
-> Parser Text
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"[") (Parser Text
 -> ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> Parser Text
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"]"

decimal :: Num a => Parser a
decimal :: forall a. Num a => Parser a
decimal = Parser a -> Parser a
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme Parser a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal

---
--- Elaboration: reconstruct cached sizes bottom-up.
---

data SigEnv = SigEnv
      { SigEnv -> HashMap Text Sig
envDefns   :: HashMap GId Sig
      , SigEnv -> HashMap Text Extern
envExterns :: HashMap Name Extern
      }

type VarEnv = HashMap Name Size

elabProgram :: MonadError AstError m => Program -> m Program
elabProgram :: forall (m :: * -> *). MonadError AstError m => Program -> m Program
elabProgram (Program [Extern]
exts [Defn]
ds Device
dev) = do
      ds'  <- (Defn -> m Defn) -> [Defn] -> m [Defn]
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 (SigEnv -> Defn -> m Defn
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> Defn -> m Defn
elabDefn SigEnv
env) [Defn]
ds
      dev' <- elabDevice env dev
      pure $ Program exts ds' dev'
      where env :: SigEnv
            env :: SigEnv
env = HashMap Text Sig -> HashMap Text Extern -> SigEnv
SigEnv ([(Text, Sig)] -> HashMap Text Sig
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Sig)] -> HashMap Text Sig)
-> [(Text, Sig)] -> HashMap Text Sig
forall a b. (a -> b) -> a -> b
$ (Defn -> (Text, Sig)) -> [Defn] -> [(Text, Sig)]
forall a b. (a -> b) -> [a] -> [b]
map (\ Defn
d -> (Defn -> Text
defnName Defn
d, Defn -> Sig
defnSig Defn
d)) [Defn]
ds)
                         ([(Text, Extern)] -> HashMap Text Extern
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Extern)] -> HashMap Text Extern)
-> [(Text, Extern)] -> HashMap Text Extern
forall a b. (a -> b) -> a -> b
$ (Extern -> (Text, Extern)) -> [Extern] -> [(Text, Extern)]
forall a b. (a -> b) -> [a] -> [b]
map (\ Extern
e -> (Extern -> Text
extName Extern
e, Extern
e)) [Extern]
exts)

elabDefn :: MonadError AstError m => SigEnv -> Defn -> m Defn
elabDefn :: forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> Defn -> m Defn
elabDefn SigEnv
env (Defn Annote
an Text
n sig :: Sig
sig@(Sig Annote
_ [Size]
argSzs Size
_) [Text]
ps Exp
body Bool
ni Blind [Text]
docs) = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Size] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Size]
argSzs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": parameter count does not match signature"
      body' <- SigEnv -> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> VarEnv -> Exp -> m Exp
elabExp SigEnv
env ([(Text, Size)] -> VarEnv
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Size)] -> VarEnv) -> [(Text, Size)] -> VarEnv
forall a b. (a -> b) -> a -> b
$ [Text] -> [Size] -> [(Text, Size)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ps [Size]
argSzs) Exp
body
      pure $ Defn an n sig ps body' ni docs

elabDevice :: MonadError AstError m => SigEnv -> Device -> m Device
elabDevice :: forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> Device -> m Device
elabDevice SigEnv
env (Device Annote
an Text
n [(Text, Size)]
ins [(Text, Size)]
outs [Register]
regs [Instance]
insts [Stmt]
body Blind [(Text, Integer)]
tags) = do
      g0    <- (VarEnv -> Instance -> m VarEnv)
-> VarEnv -> [Instance] -> m VarEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM VarEnv -> Instance -> m VarEnv
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Instance -> m VarEnv
instOuts ([(Text, Size)] -> VarEnv
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Size)] -> VarEnv) -> [(Text, Size)] -> VarEnv
forall a b. (a -> b) -> a -> b
$ [(Text, Size)]
ins [(Text, Size)] -> [(Text, Size)] -> [(Text, Size)]
forall a. Semigroup a => a -> a -> a
<> (Register -> (Text, Size)) -> [Register] -> [(Text, Size)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Register Annote
_ Text
x Size
sz BV
_) -> (Text
x, Size
sz)) [Register]
regs) [Instance]
insts
      body' <- snd <$> foldM elabStmt (g0, []) body
      pure $ Device an n ins outs regs insts (reverse body') tags
      where instOuts :: MonadError AstError m => VarEnv -> Instance -> m VarEnv
            instOuts :: forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Instance -> m VarEnv
instOuts VarEnv
g (Instance Annote
an' Text
x Text
ex [Natural]
_) = case Text -> HashMap Text Extern -> Maybe Extern
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
ex (HashMap Text Extern -> Maybe Extern)
-> HashMap Text Extern -> Maybe Extern
forall a b. (a -> b) -> a -> b
$ SigEnv -> HashMap Text Extern
envExterns SigEnv
env of
                  Just Extern
e  -> VarEnv -> m VarEnv
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarEnv -> m VarEnv) -> VarEnv -> m VarEnv
forall a b. (a -> b) -> a -> b
$ ((Text, Size) -> VarEnv -> VarEnv)
-> VarEnv -> [(Text, Size)] -> VarEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Text
p, Size
sz) -> Text -> Size -> VarEnv -> VarEnv
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p) Size
sz) VarEnv
g ([(Text, Size)] -> VarEnv) -> [(Text, Size)] -> VarEnv
forall a b. (a -> b) -> a -> b
$ Extern -> [(Text, Size)]
extOutputs Extern
e
                  Maybe Extern
Nothing -> Annote -> Text -> m VarEnv
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an' (Text -> m VarEnv) -> Text -> m VarEnv
forall a b. (a -> b) -> a -> b
$ Text
"instance " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": unknown extern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ex

            elabStmt :: MonadError AstError m => (VarEnv, [Stmt]) -> Stmt -> m (VarEnv, [Stmt])
            elabStmt :: forall (m :: * -> *).
MonadError AstError m =>
(VarEnv, [Stmt]) -> Stmt -> m (VarEnv, [Stmt])
elabStmt (VarEnv
g, [Stmt]
acc) = \ case
                  SLet Annote
an' Text
x Exp
e    -> do
                        e' <- SigEnv -> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> VarEnv -> Exp -> m Exp
elabExp SigEnv
env VarEnv
g Exp
e
                        pure (Map.insert x (sizeOf e') g, SLet an' x e' : acc)
                  SOutput Annote
an' Text
x Exp
e -> (VarEnv
g, ) ([Stmt] -> (VarEnv, [Stmt]))
-> (Exp -> [Stmt]) -> Exp -> (VarEnv, [Stmt])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
acc) (Stmt -> [Stmt]) -> (Exp -> Stmt) -> Exp -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annote -> Text -> Exp -> Stmt
SOutput Annote
an' Text
x   (Exp -> (VarEnv, [Stmt])) -> m Exp -> m (VarEnv, [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SigEnv -> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> VarEnv -> Exp -> m Exp
elabExp SigEnv
env VarEnv
g Exp
e
                  SNext Annote
an' Text
x Exp
e   -> (VarEnv
g, ) ([Stmt] -> (VarEnv, [Stmt]))
-> (Exp -> [Stmt]) -> Exp -> (VarEnv, [Stmt])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
acc) (Stmt -> [Stmt]) -> (Exp -> Stmt) -> Exp -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annote -> Text -> Exp -> Stmt
SNext Annote
an' Text
x     (Exp -> (VarEnv, [Stmt])) -> m Exp -> m (VarEnv, [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SigEnv -> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> VarEnv -> Exp -> m Exp
elabExp SigEnv
env VarEnv
g Exp
e
                  SInstIn Annote
an' Text
x Text
p Exp
e -> (VarEnv
g, ) ([Stmt] -> (VarEnv, [Stmt]))
-> (Exp -> [Stmt]) -> Exp -> (VarEnv, [Stmt])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
acc) (Stmt -> [Stmt]) -> (Exp -> Stmt) -> Exp -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annote -> Text -> Text -> Exp -> Stmt
SInstIn Annote
an' Text
x Text
p (Exp -> (VarEnv, [Stmt])) -> m Exp -> m (VarEnv, [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SigEnv -> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> VarEnv -> Exp -> m Exp
elabExp SigEnv
env VarEnv
g Exp
e

elabExp :: MonadError AstError m => SigEnv -> VarEnv -> Exp -> m Exp
elabExp :: forall (m :: * -> *).
MonadError AstError m =>
SigEnv -> VarEnv -> Exp -> m Exp
elabExp SigEnv
env = VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go
      where go :: MonadError AstError m => VarEnv -> Exp -> m Exp
            go :: forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g = \ case
                  e :: Exp
e@Lit {}            -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
                  e :: Exp
e@Undef {}          -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
                  Var Annote
an Size
_ Text
x          -> VarEnv -> Annote -> Text -> [Exp] -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Annote -> Text -> [Exp] -> m Exp
resolveName VarEnv
g Annote
an Text
x []
                  Cat Annote
an Exp
e1 Exp
e2        -> Annote -> Exp -> Exp -> Exp
Cat Annote
an (Exp -> Exp -> Exp) -> m Exp -> m (Exp -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g Exp
e1 m (Exp -> Exp) -> m Exp -> m Exp
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g Exp
e2
                  Slice Annote
an Size
i Size
k Exp
e      -> do
                        e' <- VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g Exp
e
                        unless (fromIntegral i + k <= sizeOf e') $
                              failAt an $ "slice [" <> showt i <> " +: " <> showt k
                                       <> "] out of bounds for width " <> showt (sizeOf e')
                        pure $ Slice an i k e'
                  Prim Annote
an Size
_ Op
op [Exp]
es     -> do
                        es' <- (Exp -> m Exp) -> [Exp] -> m [Exp]
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 (VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g) [Exp]
es
                        case opResultSize op $ map sizeOf es' of
                              Just Size
sz -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
Prim Annote
an Size
sz Op
op [Exp]
es'
                              Maybe Size
Nothing -> Annote -> Text -> m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an (Text -> m Exp) -> Text -> m Exp
forall a b. (a -> b) -> a -> b
$ Text
"ill-typed application of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Op -> Text
opName Op
op
                                                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to operand widths " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Size] -> Text
forall a. TextShow a => a -> Text
showt ((Exp -> Size) -> [Exp] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf [Exp]
es')
                  Call Annote
an Size
_ Text
n [Exp]
es      -> (Exp -> m Exp) -> [Exp] -> m [Exp]
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 (VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g) [Exp]
es m [Exp] -> ([Exp] -> m Exp) -> m Exp
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VarEnv -> Annote -> Text -> [Exp] -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Annote -> Text -> [Exp] -> m Exp
resolveName VarEnv
g Annote
an Text
n
                  XCall Annote
an Size
_ Text
n [Natural]
cs [Exp]
es  -> do
                        es' <- (Exp -> m Exp) -> [Exp] -> m [Exp]
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 (VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g) [Exp]
es
                        ex  <- lookupExtern an n
                        pure $ XCall an (externResultSize ex) n cs es'
                  If Annote
an Size
_ Exp
c Exp
t Exp
e       -> do
                        t' <- VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g Exp
t
                        If an (sizeOf t') <$> go g c <*> pure t' <*> go g e
                  Let Annote
an Size
_ Text
x Exp
e1 Exp
e2    -> do
                        e1' <- VarEnv -> Exp -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Exp -> m Exp
go VarEnv
g Exp
e1
                        e2' <- go (Map.insert x (sizeOf e1') g) e2
                        pure $ Let an (sizeOf e2') x e1' e2'

            -- | A name in expression position: a local variable (when there
            --   are no arguments), or a defn or extern call. Locals shadow
            --   globals.
            resolveName :: MonadError AstError m => VarEnv -> Annote -> Name -> [Exp] -> m Exp
            resolveName :: forall (m :: * -> *).
MonadError AstError m =>
VarEnv -> Annote -> Text -> [Exp] -> m Exp
resolveName VarEnv
g Annote
an Text
n [Exp]
es
                  | [Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
es, Just Size
sz <- Text -> VarEnv -> Maybe Size
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
n VarEnv
g                  = Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Text -> Exp
Var Annote
an Size
sz Text
n
                  | Just (Sig Annote
_ [Size]
_ Size
res) <- Text -> HashMap Text Sig -> Maybe Sig
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
n (HashMap Text Sig -> Maybe Sig) -> HashMap Text Sig -> Maybe Sig
forall a b. (a -> b) -> a -> b
$ SigEnv -> HashMap Text Sig
envDefns SigEnv
env   = Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Text -> [Exp] -> Exp
Call Annote
an Size
res Text
n [Exp]
es
                  | Just Extern
ex <- Text -> HashMap Text Extern -> Maybe Extern
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
n (HashMap Text Extern -> Maybe Extern)
-> HashMap Text Extern -> Maybe Extern
forall a b. (a -> b) -> a -> b
$ SigEnv -> HashMap Text Extern
envExterns SigEnv
env            = Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Text -> [Natural] -> [Exp] -> Exp
XCall Annote
an (Extern -> Size
externResultSize Extern
ex) Text
n [] [Exp]
es
                  | Bool
otherwise                                           = Annote -> Text -> m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an (Text -> m Exp) -> Text -> m Exp
forall a b. (a -> b) -> a -> b
$ Text
"unknown name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n

            lookupExtern :: MonadError AstError m => Annote -> Name -> m Extern
            lookupExtern :: forall (m :: * -> *).
MonadError AstError m =>
Annote -> Text -> m Extern
lookupExtern Annote
an Text
n = case Text -> HashMap Text Extern -> Maybe Extern
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
n (HashMap Text Extern -> Maybe Extern)
-> HashMap Text Extern -> Maybe Extern
forall a b. (a -> b) -> a -> b
$ SigEnv -> HashMap Text Extern
envExterns SigEnv
env of
                  Just Extern
ex -> Extern -> m Extern
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Extern
ex
                  Maybe Extern
Nothing -> Annote -> Text -> m Extern
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an (Text -> m Extern) -> Text -> m Extern
forall a b. (a -> b) -> a -> b
$ Text
"unknown extern: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n