{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard)
import qualified Control.Monad.Fail as Fail
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import Text.Read(readMaybe)
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Token(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident(packModName,packIdent,modNameChunks)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Cryptol.Utils.RecordMap
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString Config
cfg ParseM a
p String
cs = Config -> ParseM a -> Text -> Either ParseError a
forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p (String -> Text
T.pack String
cs)
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p Text
cs = case ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
p Config
cfg Position
eofPos S :: Maybe (Located Token) -> [Located Token] -> Int -> S
S { sPrevTok :: Maybe (Located Token)
sPrevTok = Maybe (Located Token)
forall a. Maybe a
Nothing
, sTokens :: [Located Token]
sTokens = [Located Token]
toks
, sNextTyParamNum :: Int
sNextTyParamNum = Int
0
} of
Left ParseError
err -> ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
err
Right (a
a,S
_) -> a -> Either ParseError a
forall a b. b -> Either a b
Right a
a
where ([Located Token]
toks,Position
eofPos) = Config -> Text -> ([Located Token], Position)
lexer Config
cfg Text
cs
newtype ParseM a =
P { ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP :: Config -> Position -> S -> Either ParseError (a,S) }
lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP Located Token -> ParseM a
k = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
p S
s ->
case S -> [Located Token]
sTokens S
s of
Located Token
t : [Located Token]
_ | Err TokenErr
e <- Token -> TokenT
tokenType Token
it ->
ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (ParseError -> Either ParseError (a, S))
-> ParseError -> Either ParseError (a, S)
forall a b. (a -> b) -> a -> b
$ Range -> [String] -> ParseError
HappyErrorMsg (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t) ([String] -> ParseError) -> [String] -> ParseError
forall a b. (a -> b) -> a -> b
$
[case TokenErr
e of
TokenErr
UnterminatedComment -> String
"unterminated comment"
TokenErr
UnterminatedString -> String
"unterminated string"
TokenErr
UnterminatedChar -> String
"unterminated character"
TokenErr
InvalidString -> String
"invalid string literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
InvalidChar -> String
"invalid character literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
LexicalError -> String
"unrecognized character: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
MalformedLiteral -> String
"malformed literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
MalformedSelector -> String
"malformed selector: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
InvalidIndentation TokenT
c -> String
"invalid indentation, unmatched " String -> String -> String
forall a. [a] -> [a] -> [a]
++
case TokenT
c of
Sym TokenSym
CurlyR -> String
"{ ... } "
Sym TokenSym
ParenR -> String
"( ... )"
Sym TokenSym
BracketR -> String
"[ ... ]"
TokenT
_ -> TokenT -> String
forall a. Show a => a -> String
show TokenT
c
]
where it :: Token
it = Located Token -> Token
forall a. Located a -> a
thing Located Token
t
Located Token
t : [Located Token]
more -> ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (Located Token -> ParseM a
k Located Token
t) Config
cfg Position
p S
s { sPrevTok :: Maybe (Located Token)
sPrevTok = Located Token -> Maybe (Located Token)
forall a. a -> Maybe a
Just Located Token
t, sTokens :: [Located Token]
sTokens = [Located Token]
more }
[] -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (String -> Position -> ParseError
HappyOutOfTokens (Config -> String
cfgSource Config
cfg) Position
p)
data ParseError = HappyError FilePath
(Located Token)
| HappyErrorMsg Range [String]
| HappyUnexpected FilePath (Maybe (Located Token)) String
| HappyOutOfTokens FilePath Position
deriving (Int -> ParseError -> String -> String
[ParseError] -> String -> String
ParseError -> String
(Int -> ParseError -> String -> String)
-> (ParseError -> String)
-> ([ParseError] -> String -> String)
-> Show ParseError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ParseError] -> String -> String
$cshowList :: [ParseError] -> String -> String
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> String -> String
$cshowsPrec :: Int -> ParseError -> String -> String
Show, (forall x. ParseError -> Rep ParseError x)
-> (forall x. Rep ParseError x -> ParseError) -> Generic ParseError
forall x. Rep ParseError x -> ParseError
forall x. ParseError -> Rep ParseError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParseError x -> ParseError
$cfrom :: forall x. ParseError -> Rep ParseError x
Generic, ParseError -> ()
(ParseError -> ()) -> NFData ParseError
forall a. (a -> ()) -> NFData a
rnf :: ParseError -> ()
$crnf :: ParseError -> ()
NFData)
data S = S { S -> Maybe (Located Token)
sPrevTok :: Maybe (Located Token)
, S -> [Located Token]
sTokens :: [Located Token]
, S -> Int
sNextTyParamNum :: !Int
}
ppError :: ParseError -> Doc
ppError :: ParseError -> Doc
ppError (HappyError String
path Located Token
ltok)
| Err TokenErr
_ <- Token -> TokenT
tokenType Token
tok =
String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
<+>
Token -> Doc
forall a. PP a => a -> Doc
pp Token
tok
| White TokenW
DocStr <- Token -> TokenT
tokenType Token
tok =
Doc
"Unexpected documentation (/**) comment at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
indent Int
2
Doc
"Documentation comments need to be followed by something to document."
| Bool
otherwise =
String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
indent Int
2 (String -> Doc
text String
"unexpected:" Doc -> Doc -> Doc
<+> Token -> Doc
forall a. PP a => a -> Doc
pp Token
tok)
where
pos :: Position
pos = Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
ltok)
tok :: Token
tok = Located Token -> Token
forall a. Located a -> a
thing Located Token
ltok
ppError (HappyOutOfTokens String
path Position
pos) =
String -> Doc
text String
"Unexpected end of file at:" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos
ppError (HappyErrorMsg Range
p [String]
xs) = String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
xs))
ppError (HappyUnexpected String
path Maybe (Located Token)
ltok String
e) =
Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
[ String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+> String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma ]
[Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
unexp
[Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
"expected:" Doc -> Doc -> Doc
<+> String -> Doc
text String
e]
where
([Doc]
unexp,Position
pos) =
case Maybe (Located Token)
ltok of
Maybe (Located Token)
Nothing -> ( [] ,Position
start)
Just Located Token
t -> ( [Doc
"unexpected:" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
T.unpack (Token -> Text
tokenText (Located Token -> Token
forall a. Located a -> a
thing Located Token
t)))]
, Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t)
)
instance Functor ParseM where
fmap :: (a -> b) -> ParseM a -> ParseM b
fmap = (a -> b) -> ParseM a -> ParseM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative ParseM where
pure :: a -> ParseM a
pure a
a = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
_ Position
_ S
s -> (a, S) -> Either ParseError (a, S)
forall a b. b -> Either a b
Right (a
a,S
s))
<*> :: ParseM (a -> b) -> ParseM a -> ParseM b
(<*>) = ParseM (a -> b) -> ParseM a -> ParseM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad ParseM where
return :: a -> ParseM a
return = a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
ParseM a
m >>= :: ParseM a -> (a -> ParseM b) -> ParseM b
>>= a -> ParseM b
k = (Config -> Position -> S -> Either ParseError (b, S)) -> ParseM b
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
cfg Position
p S
s1 -> case ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
m Config
cfg Position
p S
s1 of
Left ParseError
e -> ParseError -> Either ParseError (b, S)
forall a b. a -> Either a b
Left ParseError
e
Right (a
a,S
s2) -> ParseM b -> Config -> Position -> S -> Either ParseError (b, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (a -> ParseM b
k a
a) Config
cfg Position
p S
s2)
instance Fail.MonadFail ParseM where
fail :: String -> ParseM a
fail String
s = String -> [String] -> ParseM a
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] fail" [String
s]
happyError :: ParseM a
happyError :: ParseM a
happyError = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
case S -> Maybe (Located Token)
sPrevTok S
s of
Just Located Token
t -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (String -> Located Token -> ParseError
HappyError (Config -> String
cfgSource Config
cfg) Located Token
t)
Maybe (Located Token)
Nothing ->
ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [String] -> ParseError
HappyErrorMsg Range
emptyRange [String
"Parse error at the beginning of the file"])
errorMessage :: Range -> [String] -> ParseM a
errorMessage :: Range -> [String] -> ParseM a
errorMessage Range
r [String]
xs = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [String] -> ParseError
HappyErrorMsg Range
r [String]
xs)
customError :: String -> Located Token -> ParseM a
customError :: String -> Located Token -> ParseM a
customError String
x Located Token
t = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [String] -> ParseError
HappyErrorMsg (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t) [String
x])
expected :: String -> ParseM a
expected :: String -> ParseM a
expected String
x = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (String -> Maybe (Located Token) -> String -> ParseError
HappyUnexpected (Config -> String
cfgSource Config
cfg) (S -> Maybe (Located Token)
sPrevTok S
s) String
x)
mkModName :: [Text] -> ModName
mkModName :: [Text] -> ModName
mkModName = [Text] -> ModName
packModName
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema [TParam PName]
xs [Prop PName]
ps Type PName
t = [TParam PName]
-> [Prop PName] -> Type PName -> Maybe Range -> Schema PName
forall n.
[TParam n] -> [Prop n] -> Type n -> Maybe Range -> Schema n
Forall [TParam PName]
xs [Prop PName]
ps Type PName
t Maybe Range
forall a. Maybe a
Nothing
getName :: Located Token -> PName
getName :: Located Token -> PName
getName Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (Ident [] Text
x) Text
_ -> Ident -> PName
mkUnqual (Text -> Ident
mkIdent Text
x)
Token
_ -> String -> [String] -> PName
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getName" [String
"not an Ident:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]
getNum :: Located Token -> Integer
getNum :: Located Token -> Integer
getNum Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (Num Integer
x Int
_ Int
_) Text
_ -> Integer
x
Token (ChrLit Char
x) Text
_ -> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x)
Token
_ -> String -> [String] -> Integer
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getNum" [String
"not a number:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]
getChr :: Located Token -> Char
getChr :: Located Token -> Char
getChr Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (ChrLit Char
x) Text
_ -> Char
x
Token
_ -> String -> [String] -> Char
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getChr" [String
"not a char:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]
getStr :: Located Token -> String
getStr :: Located Token -> String
getStr Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (StrLit String
x) Text
_ -> String
x
Token
_ -> String -> [String] -> String
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getStr" [String
"not a string:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]
numLit :: Token -> Expr PName
numLit :: Token -> Expr PName
numLit Token { tokenText :: Token -> Text
tokenText = Text
txt, tokenType :: Token -> TokenT
tokenType = Num Integer
x Int
base Int
digs }
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
BinLit Text
txt Int
digs)
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
OctLit Text
txt Int
digs)
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> NumInfo
DecLit Text
txt)
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
HexLit Text
txt Int
digs)
numLit Token
x = String -> [String] -> Expr PName
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] numLit" [String
"invalid numeric literal", Token -> String
forall a. Show a => a -> String
show Token
x]
fracLit :: Token -> Expr PName
fracLit :: Token -> Expr PName
fracLit Token
tok =
case Token -> TokenT
tokenType Token
tok of
Frac Rational
x Int
base
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
BinFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
OctFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
DecFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
HexFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
TokenT
_ -> String -> [String] -> Expr PName
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] fracLit" [ String
"Invalid fraction", Token -> String
forall a. Show a => a -> String
show Token
tok ]
intVal :: Located Token -> ParseM Integer
intVal :: Located Token -> ParseM Integer
intVal Located Token
tok =
case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
tok) of
Num Integer
x Int
_ Int
_ -> Integer -> ParseM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
TokenT
_ -> Range -> [String] -> ParseM Integer
forall a. Range -> [String] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) [String
"Expected an integer"]
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity Assoc
assoc Located Token
tok [LPName]
qns =
do Integer
l <- Located Token -> ParseM Integer
intVal Located Token
tok
Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 Bool -> Bool -> Bool
&& Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
100)
(Range -> [String] -> ParseM ()
forall a. Range -> [String] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) [String
"Fixity levels must be between 1 and 100"])
Decl PName -> ParseM (Decl PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> [LPName] -> Decl PName
forall name. Fixity -> [Located name] -> Decl name
DFixity (Assoc -> Int -> Fixity
Fixity Assoc
assoc (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
l)) [LPName]
qns)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit Located Token
loc = case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
loc) of
StrLit String
str -> Located String -> ParseM (Located String)
forall (m :: * -> *) a. Monad m => a -> m a
return Located Token
loc { thing :: String
thing = String
str }
TokenT
_ -> Range -> [String] -> ParseM (Located String)
forall a. Range -> [String] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
loc) [String
"Expected a string literal"]
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
ty =
case Type PName
ty of
TLocated Type PName
t Range
r -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
r Type PName
t
TRecord {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Record types"
TTyApp {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Explicit type application"
TTuple {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Tuple types"
TFun {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Function types"
TSeq {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Sequence types"
Type PName
TBit -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Type bit"
TNum {} -> ParseM (Type PName)
ok
TChar {} -> ParseM (Type PName)
ok
Type PName
TWild -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Wildcard types"
TUser {} -> ParseM (Type PName)
ok
TParens Type PName
t -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
t
TInfix{} -> ParseM (Type PName)
ok
where bad :: String -> ParseM a
bad String
x = Range -> [String] -> ParseM a
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" cannot be demoted."]
ok :: ParseM (Type PName)
ok = Type PName -> ParseM (Type PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type PName -> ParseM (Type PName))
-> Type PName -> ParseM (Type PName)
forall a b. (a -> b) -> a -> b
$ Range -> Type PName -> Type PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Range
rng Type PName
ty
mkRecord :: AddLoc b => Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
mkRecord :: Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
mkRecord Range
rng RecordMap Ident (Range, a) -> b
f [Named a]
xs =
case Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
res of
Left (Ident
nm,(Range
nmRng,a
_)) -> Range -> [String] -> ParseM b
forall a. Range -> [String] -> ParseM a
errorMessage Range
nmRng [String
"Record has repeated field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
nm)]
Right RecordMap Ident (Range, a)
r -> b -> ParseM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> ParseM b) -> b -> ParseM b
forall a b. (a -> b) -> a -> b
$ Range -> b -> b
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Range
rng (RecordMap Ident (Range, a) -> b
f RecordMap Ident (Range, a)
r)
where
res :: Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
res = [(Ident, (Range, a))]
-> Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
forall a b.
(Show a, Ord a) =>
[(a, b)] -> Either (a, b) (RecordMap a b)
recordFromFieldsErr [(Ident, (Range, a))]
ys
ys :: [(Ident, (Range, a))]
ys = (Named a -> (Ident, (Range, a)))
-> [Named a] -> [(Ident, (Range, a))]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Named (Located Range
r Ident
nm) a
x) -> (Ident
nm,(Range
r,a
x))) ([Named a] -> [Named a]
forall a. [a] -> [a]
reverse [Named a]
xs)
mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)
mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)
mkEApp es :: NonEmpty (Expr PName)
es@(Expr PName
eLast :| [Expr PName]
_) =
do Expr PName
f :| [Expr PName]
xs <- Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
eFirst [Expr PName]
rest
Expr PName -> ParseM (Expr PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
eFirst,Expr PName
eLast) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ (Expr PName -> Expr PName -> Expr PName)
-> Expr PName -> [Expr PName] -> Expr PName
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f [Expr PName]
xs)
where
Expr PName
eFirst :| [Expr PName]
rest = NonEmpty (Expr PName) -> NonEmpty (Expr PName)
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty (Expr PName)
es
cvtTypeParams :: Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
e [] = NonEmpty (Expr PName) -> ParseM (NonEmpty (Expr PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr PName
e Expr PName -> [Expr PName] -> NonEmpty (Expr PName)
forall a. a -> [a] -> NonEmpty a
:| [])
cvtTypeParams Expr PName
e (Expr PName
p : [Expr PName]
ps) =
case Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
p Maybe Range
forall a. Maybe a
Nothing of
Maybe ([TypeInst PName], [Selector], Maybe Range)
Nothing -> Expr PName -> NonEmpty (Expr PName) -> NonEmpty (Expr PName)
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Expr PName
e (NonEmpty (Expr PName) -> NonEmpty (Expr PName))
-> ParseM (NonEmpty (Expr PName)) -> ParseM (NonEmpty (Expr PName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
p [Expr PName]
ps
Just ([TypeInst PName]
fs,[Selector]
ss,Maybe Range
rng) ->
if Expr PName -> Bool
forall n. Expr n -> Bool
checkAppExpr Expr PName
e then
let e' :: Expr PName
e' = (Selector -> Expr PName -> Expr PName)
-> Expr PName -> [Selector] -> Expr PName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Expr PName -> Selector -> Expr PName)
-> Selector -> Expr PName -> Expr PName
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr PName -> Selector -> Expr PName
forall n. Expr n -> Selector -> Expr n
ESel) (Expr PName -> [TypeInst PName] -> Expr PName
forall n. Expr n -> [TypeInst n] -> Expr n
EAppT Expr PName
e [TypeInst PName]
fs) [Selector]
ss
e'' :: Expr PName
e'' = case Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e) Maybe Range
rng of
Just Range
r -> Expr PName -> Range -> Expr PName
forall n. Expr n -> Range -> Expr n
ELocated Expr PName
e' Range
r
Maybe Range
Nothing -> Expr PName
e'
in Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
e'' [Expr PName]
ps
else
Range -> [String] -> ParseM (NonEmpty (Expr PName))
forall a. Range -> [String] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
emptyRange (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e))
[ String
"Explicit type applications can only be applied to named values."
, String
"Unexpected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Expr PName -> Doc
forall a. PP a => a -> Doc
pp Expr PName
e)
]
checkAppExpr :: Expr n -> Bool
checkAppExpr Expr n
e =
case Expr n
e of
ELocated Expr n
e' Range
_ -> Expr n -> Bool
checkAppExpr Expr n
e'
EParens Expr n
e' -> Expr n -> Bool
checkAppExpr Expr n
e'
EVar{} -> Bool
True
Expr n
_ -> Bool
False
toTypeParam :: Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e Maybe Range
mr =
case Expr PName
e of
ELocated Expr PName
e' Range
rng -> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' (Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Maybe Range
mr (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
ETypeVal Type PName
t -> Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall a.
Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr
ESel Expr PName
e' Selector
s -> ( \([TypeInst PName]
fs,[Selector]
ss,Maybe Range
r) -> ([TypeInst PName]
fs,Selector
sSelector -> [Selector] -> [Selector]
forall a. a -> [a] -> [a]
:[Selector]
ss,Maybe Range
r) ) (([TypeInst PName], [Selector], Maybe Range)
-> ([TypeInst PName], [Selector], Maybe Range))
-> Maybe ([TypeInst PName], [Selector], Maybe Range)
-> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' Maybe Range
mr
Expr PName
_ -> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall a. Maybe a
Nothing
toTypeParam' :: Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr =
case Type PName
t of
TLocated Type PName
t' Range
rng -> Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t' (Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Maybe Range
mr (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
TTyApp [Named (Type PName)]
fs -> ([TypeInst PName], [a], Maybe Range)
-> Maybe ([TypeInst PName], [a], Maybe Range)
forall a. a -> Maybe a
Just ((Named (Type PName) -> TypeInst PName)
-> [Named (Type PName)] -> [TypeInst PName]
forall a b. (a -> b) -> [a] -> [b]
map Named (Type PName) -> TypeInst PName
mkTypeInst [Named (Type PName)]
fs, [], Maybe Range
mr)
Type PName
_ -> Maybe ([TypeInst PName], [a], Maybe Range)
forall a. Maybe a
Nothing
unOp :: Expr PName -> Expr PName -> Expr PName
unOp :: Expr PName -> Expr PName -> Expr PName
unOp Expr PName
f Expr PName
x = (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
f,Expr PName
x) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f Expr PName
x
binOp :: Expr PName -> Located PName -> Expr PName -> Expr PName
binOp :: Expr PName -> LPName -> Expr PName -> Expr PName
binOp Expr PName
x LPName
f Expr PName
y = (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
x,Expr PName
y) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ Expr PName -> LPName -> Fixity -> Expr PName -> Expr PName
forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix Expr PName
x LPName
f Fixity
defaultFixity Expr PName
y
eFromTo :: Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> ParseM (Expr PName)
eFromTo :: Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> ParseM (Expr PName)
eFromTo Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 =
case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped (Expr PName -> Maybe (Expr PName, Type PName))
-> Maybe (Expr PName) -> Maybe (Expr PName, Type PName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expr PName)
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
(Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1' Maybe (Expr PName)
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
(Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 (Expr PName -> Maybe (Expr PName)
forall a. a -> Maybe a
Just Expr PName
e2') Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
(Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
(Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing
(Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
Maybe (Expr PName, Type PName))
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"A sequence enumeration may have at most one element type annotation."]
eFromToBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToBy :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Bool
-> ParseM (Expr PName)
eFromToBy Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Bool
isStrictBound =
case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
(Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1' Expr PName
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
(Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2' Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
(Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
(Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing Bool
isStrictBound
(Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
Maybe (Expr PName, Type PName))
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"A sequence enumeration may have at most one element type annotation."]
eFromToByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToByTyped :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
t Bool
isStrictBound =
Bool
-> Type PName
-> Type PName
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToBy Bool
isStrictBound
(Type PName
-> Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM
(Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
ParseM
(Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t
eFromToDownBy ::
Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToDownBy :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Bool
-> ParseM (Expr PName)
eFromToDownBy Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Bool
isStrictBound =
case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
(Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1' Expr PName
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
(Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2' Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
(Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
(Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing Bool
isStrictBound
(Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
Maybe (Expr PName, Type PName))
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"A sequence enumeration may have at most one element type annotation."]
eFromToDownByTyped ::
Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToDownByTyped :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
t Bool
isStrictBound =
Bool
-> Type PName
-> Type PName
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToDownBy Bool
isStrictBound
(Type PName
-> Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM
(Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
ParseM
(Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t
asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped (ELocated Expr n
e Range
_) = Expr n -> Maybe (Expr n, Type n)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr n
e
asETyped (ETyped Expr n
e Type n
t) = (Expr n, Type n) -> Maybe (Expr n, Type n)
forall a. a -> Maybe a
Just (Expr n
e, Type n
t)
asETyped Expr n
_ = Maybe (Expr n, Type n)
forall a. Maybe a
Nothing
eFromToType ::
Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType :: Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 Maybe (Type PName)
t =
Type PName
-> Maybe (Type PName)
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Type n -> Maybe (Type n) -> Type n -> Maybe (Type n) -> Expr n
EFromTo (Type PName
-> Maybe (Type PName)
-> Type PName
-> Maybe (Type PName)
-> Expr PName)
-> ParseM (Type PName)
-> ParseM
(Maybe (Type PName)
-> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
ParseM
(Maybe (Type PName)
-> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName))
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr PName -> ParseM (Type PName))
-> Maybe (Expr PName) -> ParseM (Maybe (Type PName))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r) Maybe (Expr PName)
e2
ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t
eFromToLessThan ::
Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan :: Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan Range
r Expr PName
e1 Expr PName
e2 =
case Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2 of
Just (Expr PName, Type PName)
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"The exclusive upper bound of an enumeration may not have a type annotation."]
Maybe (Expr PName, Type PName)
Nothing ->
case Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1 of
Maybe (Expr PName, Type PName)
Nothing -> Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1 Expr PName
e2 Maybe (Type PName)
forall a. Maybe a
Nothing
Just (Expr PName
e1',Type PName
t) -> Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1' Expr PName
e2 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
eFromToLessThanType ::
Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToLessThanType :: Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1 Expr PName
e2 Maybe (Type PName)
t =
Type PName -> Type PName -> Maybe (Type PName) -> Expr PName
forall n. Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToLessThan
(Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
expr =
case Expr PName -> Maybe (Type PName)
translateExprToNumT Expr PName
expr of
Just Type PName
t -> Type PName -> ParseM (Type PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
Maybe (Type PName)
Nothing -> ParseM (Type PName)
forall a. ParseM a
bad
where
bad :: ParseM a
bad = Range -> [String] -> ParseM a
forall a. Range -> [String] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
r (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
expr))
[ String
"The boundaries of .. sequences should be valid numeric types."
, String
"The expression `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Expr PName -> Doc
forall a. PP a => a -> Doc
pp Expr PName
expr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` is not."
]
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp ~(Just Range
r) [Type PName]
ts = Type PName -> Range -> Type PName
forall n. Type n -> Range -> Type n
TLocated ([Named (Type PName)] -> Type PName
forall n. [Named (Type n)] -> Type n
TTyApp ((Type PName -> Named (Type PName))
-> [Type PName] -> [Named (Type PName)]
forall a b. (a -> b) -> [a] -> [b]
map Type PName -> Named (Type PName)
forall a. a -> Named a
toField [Type PName]
ts)) Range
r
where noName :: Located Ident
noName = Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Ident
thing = Text -> Ident
mkIdent (String -> Text
T.pack String
"") }
toField :: a -> Named a
toField a
t = Named :: forall a. Located Ident -> a -> Named a
Named { name :: Located Ident
name = Located Ident
noName, value :: a
value = a
t }
exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
e Decl PName
d = TopLevel (Decl PName) -> TopDecl PName
forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
e
, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
mbDoc
, tlValue :: Decl PName
tlValue = Decl PName
d }
exportNewtype :: ExportType -> Maybe (Located Text) -> Newtype PName ->
TopDecl PName
exportNewtype :: ExportType
-> Maybe (Located Text) -> Newtype PName -> TopDecl PName
exportNewtype ExportType
e Maybe (Located Text)
d Newtype PName
n = TopLevel (Newtype PName) -> TopDecl PName
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
e
, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
d
, tlValue :: Newtype PName
tlValue = Newtype PName
n }
exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule Maybe (Located Text)
mbDoc NestedModule PName
m = TopLevel (NestedModule PName) -> TopDecl PName
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
Public
, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
mbDoc
, tlValue :: NestedModule PName
tlValue = NestedModule PName
m }
mkParFun :: Maybe (Located Text) ->
Located PName ->
Schema PName ->
TopDecl PName
mkParFun :: Maybe (Located Text) -> LPName -> Schema PName -> TopDecl PName
mkParFun Maybe (Located Text)
mbDoc LPName
n Schema PName
s = ParameterFun PName -> TopDecl PName
forall name. ParameterFun name -> TopDecl name
DParameterFun ParameterFun :: forall name.
Located name
-> Schema name -> Maybe Text -> Maybe Fixity -> ParameterFun name
ParameterFun { pfName :: LPName
pfName = LPName
n
, pfSchema :: Schema PName
pfSchema = Schema PName
s
, pfDoc :: Maybe Text
pfDoc = Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
, pfFixity :: Maybe Fixity
pfFixity = Maybe Fixity
forall a. Maybe a
Nothing
}
mkParType :: Maybe (Located Text) ->
Located PName ->
Located Kind ->
ParseM (TopDecl PName)
mkParType :: Maybe (Located Text)
-> LPName -> Located Kind -> ParseM (TopDecl PName)
mkParType Maybe (Located Text)
mbDoc LPName
n Located Kind
k =
do Int
num <- (Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int)
-> (Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
s -> let nu :: Int
nu = S -> Int
sNextTyParamNum S
s
in (Int, S) -> Either ParseError (Int, S)
forall a b. b -> Either a b
Right (Int
nu, S
s { sNextTyParamNum :: Int
sNextTyParamNum = Int
nu Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 })
TopDecl PName -> ParseM (TopDecl PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParameterType PName -> TopDecl PName
forall name. ParameterType name -> TopDecl name
DParameterType
ParameterType :: forall name.
Located name
-> Kind -> Maybe Text -> Maybe Fixity -> Int -> ParameterType name
ParameterType { ptName :: LPName
ptName = LPName
n
, ptKind :: Kind
ptKind = Located Kind -> Kind
forall a. Located a -> a
thing Located Kind
k
, ptDoc :: Maybe Text
ptDoc = Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
, ptFixity :: Maybe Fixity
ptFixity = Maybe Fixity
forall a. Maybe a
Nothing
, ptNumber :: Int
ptNumber = Int
num
})
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport ExportType
e = (TopDecl PName -> TopDecl PName)
-> [TopDecl PName] -> [TopDecl PName]
forall a b. (a -> b) -> [a] -> [b]
map TopDecl PName -> TopDecl PName
forall name. TopDecl name -> TopDecl name
change
where
change :: TopDecl name -> TopDecl name
change (Decl TopLevel (Decl name)
d) = TopLevel (Decl name) -> TopDecl name
forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel (Decl name)
d { tlExport :: ExportType
tlExport = ExportType
e }
change (DPrimType TopLevel (PrimType name)
t) = TopLevel (PrimType name) -> TopDecl name
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType name)
t { tlExport :: ExportType
tlExport = ExportType
e }
change (TDNewtype TopLevel (Newtype name)
n) = TopLevel (Newtype name) -> TopDecl name
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel (Newtype name)
n { tlExport :: ExportType
tlExport = ExportType
e }
change (DModule TopLevel (NestedModule name)
m) = TopLevel (NestedModule name) -> TopDecl name
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule name)
m { tlExport :: ExportType
tlExport = ExportType
e }
change td :: TopDecl name
td@Include{} = TopDecl name
td
change td :: TopDecl name
td@DImport{} = TopDecl name
td
change (DParameterType {}) = String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic String
"changeExport" [String
"private type parameter?"]
change (DParameterFun {}) = String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic String
"changeExport" [String
"private value parameter?"]
change (DParameterConstraint {}) =
String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic String
"changeExport" [String
"private type constraint parameter?"]
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst Named (Type PName)
x | Ident -> Bool
nullIdent (Located Ident -> Ident
forall a. Located a -> a
thing (Named (Type PName) -> Located Ident
forall a. Named a -> Located Ident
name Named (Type PName)
x)) = Type PName -> TypeInst PName
forall name. Type name -> TypeInst name
PosInst (Named (Type PName) -> Type PName
forall a. Named a -> a
value Named (Type PName)
x)
| Bool
otherwise = Named (Type PName) -> TypeInst PName
forall name. Named (Type name) -> TypeInst name
NamedInst Named (Type PName)
x
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam Located { srcRange :: forall a. Located a -> Range
srcRange = Range
rng, thing :: forall a. Located a -> a
thing = Ident
n } Maybe Kind
k
| Ident
n Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent = Range -> [String] -> ParseM (TParam PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
"`width` is not a valid type parameter name."]
| Bool
otherwise = TParam PName -> ParseM (TParam PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Maybe Kind -> Maybe Range -> TParam PName
forall n. n -> Maybe Kind -> Maybe Range -> TParam n
TParam (Ident -> PName
mkUnqual Ident
n) Maybe Kind
k (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
mkTySyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkTySyn :: LPName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkTySyn LPName
ln [TParam PName]
ps Type PName
b
| PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln) Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent =
Range -> [String] -> ParseM (Decl PName)
forall a. Range -> [String] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
ln) [String
"`width` is not a valid type synonym name."]
| Bool
otherwise =
Decl PName -> ParseM (Decl PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PName -> ParseM (Decl PName))
-> Decl PName -> ParseM (Decl PName)
forall a b. (a -> b) -> a -> b
$ TySyn PName -> Decl PName
forall name. TySyn name -> Decl name
DType (TySyn PName -> Decl PName) -> TySyn PName -> Decl PName
forall a b. (a -> b) -> a -> b
$ LPName
-> Maybe Fixity -> [TParam PName] -> Type PName -> TySyn PName
forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn LPName
ln Maybe Fixity
forall a. Maybe a
Nothing [TParam PName]
ps Type PName
b
mkPropSyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkPropSyn :: LPName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkPropSyn LPName
ln [TParam PName]
ps Type PName
b
| PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln) Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent =
Range -> [String] -> ParseM (Decl PName)
forall a. Range -> [String] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
ln) [String
"`width` is not a valid constraint synonym name."]
| Bool
otherwise =
PropSyn PName -> Decl PName
forall name. PropSyn name -> Decl name
DProp (PropSyn PName -> Decl PName)
-> (Located [Prop PName] -> PropSyn PName)
-> Located [Prop PName]
-> Decl PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPName
-> Maybe Fixity -> [TParam PName] -> [Prop PName] -> PropSyn PName
forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn LPName
ln Maybe Fixity
forall a. Maybe a
Nothing [TParam PName]
ps ([Prop PName] -> PropSyn PName)
-> (Located [Prop PName] -> [Prop PName])
-> Located [Prop PName]
-> PropSyn PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located [Prop PName] -> [Prop PName]
forall a. Located a -> a
thing (Located [Prop PName] -> Decl PName)
-> ParseM (Located [Prop PName]) -> ParseM (Decl PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
b
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm Range
rng Integer
k Integer
p
| Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = (Bool, Integer) -> ParseM (Bool, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Integer
p)
| Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = (Bool, Integer) -> ParseM (Bool, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Integer
p)
| Bool
otherwise = Range -> [String] -> ParseM (Bool, Integer)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
"Invalid polynomial coefficient"]
mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly :: Range -> [(Bool, Integer)] -> ParseM (Expr PName)
mkPoly Range
rng [(Bool, Integer)]
terms
| Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) = Integer -> [Int] -> ParseM (Expr PName)
mk Integer
0 ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a. Num a => Integer -> a
fromInteger [Integer]
bits)
| Bool
otherwise = Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
"Polynomial literal too large: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
w]
where
w :: Integer
w = case [(Bool, Integer)]
terms of
[] -> Integer
0
[(Bool, Integer)]
_ -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((Bool, Integer) -> Integer) -> [(Bool, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Integer) -> Integer
forall a b. (a, b) -> b
snd [(Bool, Integer)]
terms)
bits :: [Integer]
bits = [ Integer
n | (Bool
True,Integer
n) <- [(Bool, Integer)]
terms ]
mk :: Integer -> [Int] -> ParseM (Expr PName)
mk :: Integer -> [Int] -> ParseM (Expr PName)
mk Integer
res [] = Expr PName -> ParseM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr PName -> ParseM (Expr PName))
-> Expr PName -> ParseM (Expr PName)
forall a b. (a -> b) -> a -> b
$ Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
res (Int -> NumInfo
PolyLit (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
w :: Int))
mk Integer
res (Int
n : [Int]
ns)
| Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
res Int
n = Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng
[String
"Polynomial contains multiple terms with exponent " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n]
| Bool
otherwise = Integer -> [Int] -> ParseM (Expr PName)
mk (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
setBit Integer
res Int
n) [Int]
ns
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty LPName
f [Pattern PName]
ps Expr PName
e = (LPName, Expr PName) -> Decl PName -> Decl PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (LPName
f,Expr PName
e) (Decl PName -> Decl PName) -> Decl PName -> Decl PName
forall a b. (a -> b) -> a -> b
$
Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> ExportType
-> Bind name
Bind { bName :: LPName
bName = LPName
f
, bParams :: [Pattern PName]
bParams = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
, bDef :: Located (BindDef PName)
bDef = Expr PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange (Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
DExpr Expr PName
e))
, bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = [Pragma
PragmaProperty]
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Bool
False
, bFixity :: Maybe Fixity
bFixity = Maybe Fixity
forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = Maybe Text
forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
}
mkIndexedDecl ::
LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl :: LPName
-> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl LPName
f ([Pattern PName]
ps, [Pattern PName]
ixs) Expr PName
e =
Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> ExportType
-> Bind name
Bind { bName :: LPName
bName = LPName
f
, bParams :: [Pattern PName]
bParams = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
, bDef :: Located (BindDef PName)
bDef = Expr PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange (Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
DExpr Expr PName
rhs))
, bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Bool
False
, bFixity :: Maybe Fixity
bFixity = Maybe Fixity
forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = Maybe Text
forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
}
where
rhs :: Expr PName
rhs :: Expr PName
rhs = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
e
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr ([Pattern PName]
ps, [Pattern PName]
ixs) Expr PName
body
| [Pattern PName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ps = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body
| Bool
otherwise = FunDesc PName -> [Pattern PName] -> Expr PName -> Expr PName
forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
forall n. FunDesc n
emptyFunDesc ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps) ([Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body)
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate [Pattern PName]
pats Expr PName
body =
(Pattern PName -> Expr PName -> Expr PName)
-> Expr PName -> [Pattern PName] -> Expr PName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pattern PName
pat Expr PName
e -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EGenerate (FunDesc PName -> [Pattern PName] -> Expr PName -> Expr PName
forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
forall n. FunDesc n
emptyFunDesc [Pattern PName
pat] Expr PName
e)) Expr PName
body [Pattern PName]
pats
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf [(Expr PName, Expr PName)]
ifThens Expr PName
theElse = ((Expr PName, Expr PName) -> Expr PName -> Expr PName)
-> Expr PName -> [(Expr PName, Expr PName)] -> Expr PName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall n. (Expr n, Expr n) -> Expr n -> Expr n
addIfThen Expr PName
theElse [(Expr PName, Expr PName)]
ifThens
where
addIfThen :: (Expr n, Expr n) -> Expr n -> Expr n
addIfThen (Expr n
cond, Expr n
doexpr) Expr n
elseExpr = Expr n -> Expr n -> Expr n -> Expr n
forall n. Expr n -> Expr n -> Expr n -> Expr n
EIf Expr n
cond Expr n
doexpr Expr n
elseExpr
mkPrimDecl ::
Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl Maybe (Located Text)
mbDoc LPName
ln Schema PName
sig =
[ Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
Public
(Decl PName -> TopDecl PName) -> Decl PName -> TopDecl PName
forall a b. (a -> b) -> a -> b
$ Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> ExportType
-> Bind name
Bind { bName :: LPName
bName = LPName
ln
, bParams :: [Pattern PName]
bParams = []
, bDef :: Located (BindDef PName)
bDef = Schema PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Schema PName
sig (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange BindDef PName
forall name. BindDef name
DPrim)
, bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Ident -> Bool
isInfixIdent (PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln))
, bFixity :: Maybe Fixity
bFixity = Maybe Fixity
forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = Maybe Text
forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
}
, Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
forall a. Maybe a
Nothing ExportType
Public
(Decl PName -> TopDecl PName) -> Decl PName -> TopDecl PName
forall a b. (a -> b) -> a -> b
$ [LPName] -> Schema PName -> Decl PName
forall name. [Located name] -> Schema name -> Decl name
DSignature [LPName
ln] Schema PName
sig
]
mkPrimTypeDecl ::
Maybe (Located Text) ->
Schema PName ->
Located Kind ->
ParseM [TopDecl PName]
mkPrimTypeDecl :: Maybe (Located Text)
-> Schema PName -> Located Kind -> ParseM [TopDecl PName]
mkPrimTypeDecl Maybe (Located Text)
mbDoc (Forall [TParam PName]
as [Prop PName]
qs Type PName
st ~(Just Range
schema_rng)) Located Kind
finK =
case Range -> Type PName -> Maybe (LPName, [LPName])
forall a. Eq a => Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
schema_rng Type PName
st of
Just (LPName
n,[LPName]
xs) ->
do [(PName, (TParam PName, Kind))]
vs <- (TParam PName -> ParseM (PName, (TParam PName, Kind)))
-> [TParam PName] -> ParseM [(PName, (TParam PName, Kind))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TParam PName -> ParseM (PName, (TParam PName, Kind))
forall n. TParam n -> ParseM (n, (TParam n, Kind))
tpK [TParam PName]
as
Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PName] -> Bool
forall a. Eq a => [a] -> Bool
distinct (((PName, (TParam PName, Kind)) -> PName)
-> [(PName, (TParam PName, Kind))] -> [PName]
forall a b. (a -> b) -> [a] -> [b]
map (PName, (TParam PName, Kind)) -> PName
forall a b. (a, b) -> a
fst [(PName, (TParam PName, Kind))]
vs)) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
Range -> [String] -> ParseM ()
forall a. Range -> [String] -> ParseM a
errorMessage Range
schema_rng [String
"Repeated parameters."]
let kindMap :: Map PName (TParam PName, Kind)
kindMap = [(PName, (TParam PName, Kind))] -> Map PName (TParam PName, Kind)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PName, (TParam PName, Kind))]
vs
lkp :: LPName -> ParseM (TParam PName, Kind)
lkp LPName
v = case PName
-> Map PName (TParam PName, Kind) -> Maybe (TParam PName, Kind)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LPName -> PName
forall a. Located a -> a
thing LPName
v) Map PName (TParam PName, Kind)
kindMap of
Just (TParam PName
k,Kind
tp) -> (TParam PName, Kind) -> ParseM (TParam PName, Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam PName
k,Kind
tp)
Maybe (TParam PName, Kind)
Nothing ->
Range -> [String] -> ParseM (TParam PName, Kind)
forall a. Range -> [String] -> ParseM a
errorMessage
(LPName -> Range
forall a. Located a -> Range
srcRange LPName
v)
[String
"Undefined parameter: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (PName -> Doc
forall a. PP a => a -> Doc
pp (LPName -> PName
forall a. Located a -> a
thing LPName
v))]
([TParam PName]
as',[Kind]
ins) <- [(TParam PName, Kind)] -> ([TParam PName], [Kind])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TParam PName, Kind)] -> ([TParam PName], [Kind]))
-> ParseM [(TParam PName, Kind)] -> ParseM ([TParam PName], [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LPName -> ParseM (TParam PName, Kind))
-> [LPName] -> ParseM [(TParam PName, Kind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPName -> ParseM (TParam PName, Kind)
lkp [LPName]
xs
Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PName, (TParam PName, Kind))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PName, (TParam PName, Kind))]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [LPName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPName]
xs) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
Range -> [String] -> ParseM ()
forall a. Range -> [String] -> ParseM a
errorMessage Range
schema_rng [String
"All parameters should appear in the type."]
let ki :: Located Kind
ki = Located Kind
finK { thing :: Kind
thing = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Kind -> Kind -> Kind
KFun (Located Kind -> Kind
forall a. Located a -> a
thing Located Kind
finK) [Kind]
ins }
[TopDecl PName] -> ParseM [TopDecl PName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TopLevel (PrimType PName) -> TopDecl PName
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel
{ tlExport :: ExportType
tlExport = ExportType
Public
, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
mbDoc
, tlValue :: PrimType PName
tlValue = PrimType :: forall name.
Located name
-> Located Kind
-> ([TParam name], [Prop name])
-> Maybe Fixity
-> PrimType name
PrimType { primTName :: LPName
primTName = LPName
n
, primTKind :: Located Kind
primTKind = Located Kind
ki
, primTCts :: ([TParam PName], [Prop PName])
primTCts = ([TParam PName]
as',[Prop PName]
qs)
, primTFixity :: Maybe Fixity
primTFixity = Maybe Fixity
forall a. Maybe a
Nothing
}
}
]
Maybe (LPName, [LPName])
Nothing -> Range -> [String] -> ParseM [TopDecl PName]
forall a. Range -> [String] -> ParseM a
errorMessage Range
schema_rng [String
"Invalid primitive signature"]
where
splitT :: Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r Type a
ty = case Type a
ty of
TLocated Type a
t Range
r1 -> Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r1 Type a
t
TUser a
n [Type a]
ts -> Range -> Located a -> [Type a] -> Maybe (Located a, [Located a])
forall a a.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n } [Type a]
ts
TInfix Type a
t1 Located a
n Fixity
_ Type a
t2 -> Range -> Located a -> [Type a] -> Maybe (Located a, [Located a])
forall a a.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r Located a
n [Type a
t1,Type a
t2]
Type a
_ -> Maybe (Located a, [Located a])
forall a. Maybe a
Nothing
mkT :: Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r a
n [Type a]
ts = do [Located a]
ts1 <- (Type a -> Maybe (Located a)) -> [Type a] -> Maybe [Located a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type a -> Maybe (Located a)
forall a. Range -> Type a -> Maybe (Located a)
isVar Range
r) [Type a]
ts
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([a] -> Bool
forall a. Eq a => [a] -> Bool
distinct ((Located a -> a) -> [Located a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Located a -> a
forall a. Located a -> a
thing [Located a]
ts1))
(a, [Located a]) -> Maybe (a, [Located a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n,[Located a]
ts1)
isVar :: Range -> Type a -> Maybe (Located a)
isVar Range
r Type a
ty = case Type a
ty of
TLocated Type a
t Range
r1 -> Range -> Type a -> Maybe (Located a)
isVar Range
r1 Type a
t
TUser a
n [] -> Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n }
Type a
_ -> Maybe (Located a)
forall a. Maybe a
Nothing
distinct :: [a] -> Bool
distinct [a]
xs = case [a]
xs of
[] -> Bool
True
a
x : [a]
ys -> Bool -> Bool
not (a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ys) Bool -> Bool -> Bool
&& [a] -> Bool
distinct [a]
ys
tpK :: TParam n -> ParseM (n, (TParam n, Kind))
tpK TParam n
tp = case TParam n -> Maybe Kind
forall n. TParam n -> Maybe Kind
tpKind TParam n
tp of
Just Kind
k -> (n, (TParam n, Kind)) -> ParseM (n, (TParam n, Kind))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam n -> n
forall n. TParam n -> n
tpName TParam n
tp, (TParam n
tp,Kind
k))
Maybe Kind
Nothing ->
case TParam n -> Maybe Range
forall n. TParam n -> Maybe Range
tpRange TParam n
tp of
Just Range
r -> Range -> [String] -> ParseM (n, (TParam n, Kind))
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"Parameters need a kind annotation"]
Maybe Range
Nothing -> String -> [String] -> ParseM (n, (TParam n, Kind))
forall a. HasCallStack => String -> [String] -> a
panic String
"mkPrimTypeDecl"
[ String
"Missing range on schema parameter." ]
mkDoc :: Located Text -> Located Text
mkDoc :: Located Text -> Located Text
mkDoc Located Text
ltxt = Located Text
ltxt { thing :: Text
thing = Text
docStr }
where
docStr :: Text
docStr = [Text] -> Text
T.unlines
([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
dropPrefix
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
trimFront
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines
(Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
commentChar
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Located Text -> Text
forall a. Located a -> a
thing Located Text
ltxt
commentChar :: Char -> Bool
commentChar :: Char -> Bool
commentChar Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"/* \r\n\t" :: String)
prefixDroppable :: Char -> Bool
prefixDroppable Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"* \r\n\t" :: String)
whitespaceChar :: Char -> Bool
whitespaceChar :: Char -> Bool
whitespaceChar Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
" \r\n\t" :: String)
trimFront :: [Text] -> [Text]
trimFront [] = []
trimFront (Text
l:[Text]
ls)
| (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
commentChar Text
l = [Text]
ls
| Bool
otherwise = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ls
dropPrefix :: [Text] -> [Text]
dropPrefix [] = []
dropPrefix [Text
t] = [(Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
t]
dropPrefix ts :: [Text]
ts@(Text
l:[Text]
ls) =
case Text -> Maybe (Char, Text)
T.uncons Text
l of
Just (Char
c,Text
_) | Char -> Bool
prefixDroppable Char
c Bool -> Bool -> Bool
&&
(Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Text -> Bool
commonPrefix Char
c) [Text]
ls -> [Text] -> [Text]
dropPrefix ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
T.drop Int
1) [Text]
ts)
Maybe (Char, Text)
_ -> [Text]
ts
where
commonPrefix :: Char -> Text -> Bool
commonPrefix Char
c Text
t =
case Text -> Maybe (Char, Text)
T.uncons Text
t of
Just (Char
c',Text
_) -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'
Maybe (Char, Text)
Nothing -> Char -> Bool
whitespaceChar Char
c
distrLoc :: Located [a] -> [Located a]
distrLoc :: Located [a] -> [Located a]
distrLoc Located [a]
x = [ Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
a } | a
a <- Located [a] -> [a]
forall a. Located a -> a
thing Located [a]
x ]
where r :: Range
r = Located [a] -> Range
forall a. Located a -> Range
srcRange Located [a]
x
mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty =
case Type PName
ty of
TLocated Type PName
t Range
r -> Range -> [Prop PName] -> Located [Prop PName]
forall a. Range -> a -> Located a
Located Range
r ([Prop PName] -> Located [Prop PName])
-> ParseM [Prop PName] -> ParseM (Located [Prop PName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Range -> Type PName -> ParseM [Prop PName]
forall n. Range -> Type n -> ParseM [Prop n]
props Range
r Type PName
t
Type PName
_ -> String -> [String] -> ParseM (Located [Prop PName])
forall a. HasCallStack => String -> [String] -> a
panic String
"Parser" [ String
"Invalid type given to mkProp"
, String
"expected a location"
, Type PName -> String
forall a. Show a => a -> String
show Type PName
ty ]
where
props :: Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t =
case Type n
t of
TInfix{} -> [Prop n] -> ParseM [Prop n]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type n -> Prop n
forall n. Type n -> Prop n
CType Type n
t]
TUser{} -> [Prop n] -> ParseM [Prop n]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type n -> Prop n
forall n. Type n -> Prop n
CType Type n
t]
TTuple [Type n]
ts -> [[Prop n]] -> [Prop n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Prop n]] -> [Prop n]) -> ParseM [[Prop n]] -> ParseM [Prop n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Type n -> ParseM [Prop n]) -> [Type n] -> ParseM [[Prop n]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type n -> ParseM [Prop n]
props Range
r) [Type n]
ts
TParens Type n
t' -> Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t'
TLocated Type n
t' Range
r' -> Range -> Type n -> ParseM [Prop n]
props Range
r' Type n
t'
TFun{} -> ParseM [Prop n]
forall a. ParseM a
err
TSeq{} -> ParseM [Prop n]
forall a. ParseM a
err
TBit{} -> ParseM [Prop n]
forall a. ParseM a
err
TNum{} -> ParseM [Prop n]
forall a. ParseM a
err
TChar{} -> ParseM [Prop n]
forall a. ParseM a
err
Type n
TWild -> ParseM [Prop n]
forall a. ParseM a
err
TRecord{} -> ParseM [Prop n]
forall a. ParseM a
err
TTyApp{} -> ParseM [Prop n]
forall a. ParseM a
err
where
err :: ParseM a
err = Range -> [String] -> ParseM a
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"Invalid constraint"]
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule Located ModName
nm [TopDecl PName]
ds = Module :: forall mname name.
Located mname
-> Maybe (Located ModName) -> [TopDecl name] -> ModuleG mname name
Module { mName :: Located ModName
mName = Located ModName
nm
, mInstance :: Maybe (Located ModName)
mInstance = Maybe (Located ModName)
forall a. Maybe a
Nothing
, mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds
}
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested Module PName
m =
case ModName -> [String]
modNameChunks (Located ModName -> ModName
forall a. Located a -> a
thing Located ModName
nm) of
[String
c] -> NestedModule PName -> ParseM (NestedModule PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleG PName PName -> NestedModule PName
forall name. ModuleG name name -> NestedModule name
NestedModule Module PName
m { mName :: LPName
mName = Located ModName
nm { thing :: PName
thing = Ident -> PName
mkUnqual (String -> Ident
packIdent String
c)}})
[String]
_ -> Range -> [String] -> ParseM (NestedModule PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r
[String
"Nested modules names should be a simple identifier."]
where
nm :: Located ModName
nm = Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
mName Module PName
m
r :: Range
r = Located ModName -> Range
forall a. Located a -> Range
srcRange Located ModName
nm
mkAnonymousModule :: [TopDecl PName] -> Module PName
mkAnonymousModule :: [TopDecl PName] -> Module PName
mkAnonymousModule = Located ModName -> [TopDecl PName] -> Module PName
mkModule Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
emptyRange
, thing :: ModName
thing = [Text] -> ModName
mkModName [String -> Text
T.pack String
"Main"]
}
mkModuleInstance :: Located ModName ->
Located ModName ->
[TopDecl PName] ->
Module PName
mkModuleInstance :: Located ModName
-> Located ModName -> [TopDecl PName] -> Module PName
mkModuleInstance Located ModName
nm Located ModName
fun [TopDecl PName]
ds =
Module :: forall mname name.
Located mname
-> Maybe (Located ModName) -> [TopDecl name] -> ModuleG mname name
Module { mName :: Located ModName
mName = Located ModName
nm
, mInstance :: Maybe (Located ModName)
mInstance = Located ModName -> Maybe (Located ModName)
forall a. a -> Maybe a
Just Located ModName
fun
, mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds
}
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField UpdHow
h [Located Selector]
ls Expr PName
e) =
case (UpdHow
h,[Located Selector]
ls) of
(UpdHow
UpdSet, [Located Selector
l]) | RecordSel Ident
i Maybe [Ident]
Nothing <- Located Selector -> Selector
forall a. Located a -> a
thing Located Selector
l ->
Named (Expr PName) -> ParseM (Named (Expr PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Named :: forall a. Located Ident -> a -> Named a
Named { name :: Located Ident
name = Located Selector
l { thing :: Ident
thing = Ident
i }, value :: Expr PName
value = Expr PName
e }
(UpdHow, [Located Selector])
_ -> Range -> [String] -> ParseM (Named (Expr PName))
forall a. Range -> [String] -> ParseM a
errorMessage (Located Selector -> Range
forall a. Located a -> Range
srcRange ([Located Selector] -> Located Selector
forall a. [a] -> a
head [Located Selector]
ls))
[String
"Invalid record field. Perhaps you meant to update a record?"]
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath Expr PName
e0 = [Located Selector] -> [Located Selector]
forall a. [a] -> [a]
reverse ([Located Selector] -> [Located Selector])
-> ParseM [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM [Located Selector]
go Range
forall a. a
noLoc Expr PName
e0
where
noLoc :: a
noLoc = String -> [String] -> a
forall a. HasCallStack => String -> [String] -> a
panic String
"selExprToSels" [String
"Missing location?"]
go :: Range -> Expr PName -> ParseM [Located Selector]
go Range
loc Expr PName
expr =
case Expr PName
expr of
ELocated Expr PName
e1 Range
r -> Range -> Expr PName -> ParseM [Located Selector]
go Range
r Expr PName
e1
ESel Expr PName
e2 Selector
s ->
do [Located Selector]
ls <- Range -> Expr PName -> ParseM [Located Selector]
go Range
loc Expr PName
e2
let rng :: Range
rng = Range
loc { from :: Position
from = Range -> Position
to (Located Selector -> Range
forall a. Located a -> Range
srcRange ([Located Selector] -> Located Selector
forall a. [a] -> a
head [Located Selector]
ls)) }
[Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Selector
s, srcRange :: Range
srcRange = Range
rng } Located Selector -> [Located Selector] -> [Located Selector]
forall a. a -> [a] -> [a]
: [Located Selector]
ls)
EVar (UnQual Ident
l) ->
[Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Ident -> Maybe [Ident] -> Selector
RecordSel Ident
l Maybe [Ident]
forall a. Maybe a
Nothing, srcRange :: Range
srcRange = Range
loc } ]
ELit (ECNum Integer
n (DecLit {})) ->
[Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) Maybe Int
forall a. Maybe a
Nothing
, srcRange :: Range
srcRange = Range
loc } ]
ELit (ECFrac Rational
_ (DecFrac Text
txt))
| (Text
as,Text
bs') <- (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
txt
, Just Int
a <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
as)
, Just (Char
_,Text
bs) <- Text -> Maybe (Char, Text)
T.uncons Text
bs'
, Just Int
b <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
bs)
, let fromP :: Position
fromP = Range -> Position
from Range
loc
, let midP :: Position
midP = Position
fromP { col :: Int
col = Position -> Int
col Position
fromP Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } ->
[Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel Int
b Maybe Int
forall a. Maybe a
Nothing
, srcRange :: Range
srcRange = Range
loc { from :: Position
from = Position
midP }
}
, Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel Int
a Maybe Int
forall a. Maybe a
Nothing
, srcRange :: Range
srcRange = Range
loc { to :: Position
to = Position
midP }
}
]
Expr PName
_ -> Range -> [String] -> ParseM [Located Selector]
forall a. Range -> [String] -> ParseM a
errorMessage Range
loc [String
"Invalid label in record update."]
mkSelector :: Token -> Selector
mkSelector :: Token -> Selector
mkSelector Token
tok =
case Token -> TokenT
tokenType Token
tok of
Selector (TupleSelectorTok Int
n) -> Int -> Maybe Int -> Selector
TupleSel Int
n Maybe Int
forall a. Maybe a
Nothing
Selector (RecordSelectorTok Text
t) -> Ident -> Maybe [Ident] -> Selector
RecordSel (Text -> Ident
mkIdent Text
t) Maybe [Ident]
forall a. Maybe a
Nothing
TokenT
_ -> String -> [String] -> Selector
forall a. HasCallStack => String -> [String] -> a
panic String
"mkSelector"
[ String
"Unexpected selector token", Token -> String
forall a. Show a => a -> String
show Token
tok ]