{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Cryptol.Parser.ParserUtils where
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Control.Monad(liftM,ap,unless,guard)
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident(packModName)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString cfg :: Config
cfg p :: ParseM a
p cs :: 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 cfg :: Config
cfg p :: ParseM a
p cs :: 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 $WS :: 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 = 0
} of
Left err :: ParseError
err -> ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
err
Right (a :: a
a,_) -> a -> Either ParseError a
forall a b. b -> Either a b
Right a
a
where (toks :: [Located Token]
toks,eofPos :: 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 k :: 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
$ \cfg :: Config
cfg p :: Position
p s :: S
s ->
case S -> [Located Token]
sTokens S
s of
t :: Located Token
t : _ | Err e :: 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
UnterminatedComment -> "unterminated comment"
UnterminatedString -> "unterminated string"
UnterminatedChar -> "unterminated character"
InvalidString -> "invalid string literal:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
InvalidChar -> "invalid character literal:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
LexicalError -> "unrecognized character:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack (Token -> Text
tokenText Token
it)
where it :: Token
it = Located Token -> Token
forall a. Located a -> a
thing Located Token
t
t :: Located Token
t : more :: [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 path :: String
path ltok :: Located Token
ltok)
| Err _ <- Token -> TokenT
tokenType Token
tok =
String -> Doc
text "Parse error at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
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 DocStr <- Token -> TokenT
tokenType Token
tok =
"Unexpected documentation (/**) comment at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
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
nest 2
"Documentation comments need to be followed by something to document."
| Bool
otherwise =
String -> Doc
text "Parse error at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
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
nest 2 (String -> Doc
text "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 path :: String
path pos :: Position
pos) =
String -> Doc
text "Unexpected end of file at:" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char ':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos
ppError (HappyErrorMsg p :: Range
p x :: String
x) = String -> Doc
text "Parse error at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 (String -> Doc
text String
x)
ppError (HappyUnexpected path :: String
path ltok :: Maybe (Located Token)
ltok e :: String
e) =
String -> Doc
text "Parse error at" Doc -> Doc -> Doc
<+>
String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
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
nest 2 Doc
unexp Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest 2 ("expected:" Doc -> Doc -> Doc
<+> String -> Doc
text String
e)
where
(unexp :: Doc
unexp,pos :: Position
pos) =
case Maybe (Located Token)
ltok of
Nothing -> (Doc
empty,Position
start)
Just t :: Located Token
t -> ( "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 -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: 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 :: a
a = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\_ _ s :: S
s -> (a, S) -> Either ParseError (a, S)
forall a b. b -> Either a b
Right (a
a,S
s))
m :: ParseM a
m >>= :: ParseM a -> (a -> ParseM b) -> ParseM b
>>= k :: 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 (\cfg :: Config
cfg p :: Position
p s1 :: 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 e :: ParseError
e -> ParseError -> Either ParseError (b, S)
forall a b. a -> Either a b
Left ParseError
e
Right (a :: a
a,s2 :: 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 MonadFail ParseM where
fail :: String -> ParseM a
fail s :: String
s = String -> [String] -> ParseM a
forall a. HasCallStack => String -> [String] -> a
panic "[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
$ \cfg :: Config
cfg _ s :: S
s ->
case S -> Maybe (Located Token)
sPrevTok S
s of
Just t :: 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)
Nothing ->
ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> String -> ParseError
HappyErrorMsg Range
emptyRange "Parse error at the beginning of the file")
errorMessage :: Range -> String -> ParseM a
errorMessage :: Range -> String -> ParseM a
errorMessage r :: Range
r x :: 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
$ \_ _ _ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> String -> ParseError
HappyErrorMsg Range
r String
x)
customError :: String -> Located Token -> ParseM a
customError :: String -> Located Token -> ParseM a
customError x :: String
x t :: 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
$ \_ _ _ -> 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 x :: 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
$ \cfg :: Config
cfg _ s :: 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 xs :: [TParam PName]
xs ps :: [Prop PName]
ps t :: 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 l :: Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (Ident [] x :: Text
x) _ -> Ident -> PName
mkUnqual (Text -> Ident
mkIdent Text
x)
_ -> String -> [String] -> PName
forall a. HasCallStack => String -> [String] -> a
panic "[Parser] getName" ["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 l :: Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (Num x :: Integer
x _ _) _ -> Integer
x
Token (ChrLit x :: Char
x) _ -> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x)
_ -> String -> [String] -> Integer
forall a. HasCallStack => String -> [String] -> a
panic "[Parser] getNum" ["not a number:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]
getStr :: Located Token -> String
getStr :: Located Token -> String
getStr l :: Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
Token (StrLit x :: String
x) _ -> String
x
_ -> String -> [String] -> String
forall a. HasCallStack => String -> [String] -> a
panic "[Parser] getStr" ["not a string:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]
numLit :: TokenT -> Expr PName
numLit :: TokenT -> Expr PName
numLit (Num x :: Integer
x base :: Int
base digs :: Int
digs)
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (Int -> NumInfo
BinLit Int
digs)
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (Int -> NumInfo
OctLit Int
digs)
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 NumInfo
DecLit
| Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (Int -> NumInfo
HexLit Int
digs)
numLit x :: TokenT
x = String -> [String] -> Expr PName
forall a. HasCallStack => String -> [String] -> a
panic "[Parser] numLit" ["invalid numeric literal", TokenT -> String
forall a. Show a => a -> String
show TokenT
x]
intVal :: Located Token -> ParseM Integer
intVal :: Located Token -> ParseM Integer
intVal tok :: Located Token
tok =
case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
tok) of
Num x :: Integer
x _ _ -> Integer -> ParseM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
_ -> Range -> String -> ParseM Integer
forall a. Range -> String -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) "Expected an integer"
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity assoc :: Assoc
assoc tok :: Located Token
tok qns :: [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
>= 1 Bool -> Bool -> Bool
&& Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 100)
(Range -> String -> ParseM ()
forall a. Range -> String -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) "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)
mkTupleSel :: Range -> Integer -> ParseM (Located Selector)
mkTupleSel :: Range -> Integer -> ParseM (Located Selector)
mkTupleSel pos :: Range
pos n :: Integer
n
| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Range -> String -> ParseM (Located Selector)
forall a. Range -> String -> ParseM a
errorMessage Range
pos
(Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not a valid tuple selector (they start from 0).")
| Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
asInt Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
n = Range -> String -> ParseM (Located Selector)
forall a. Range -> String -> ParseM a
errorMessage Range
pos "Tuple selector is too large."
| Bool
otherwise = Located Selector -> ParseM (Located Selector)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Selector -> ParseM (Located Selector))
-> Located Selector -> ParseM (Located Selector)
forall a b. (a -> b) -> a -> b
$ Range -> Selector -> Located Selector
forall a. Range -> a -> Located a
Located Range
pos (Selector -> Located Selector) -> Selector -> Located Selector
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Selector
TupleSel Int
asInt Maybe Int
forall a. Maybe a
Nothing
where asInt :: Int
asInt = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit loc :: Located Token
loc = case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
loc) of
StrLit str :: String
str -> Located String -> ParseM (Located String)
forall (m :: * -> *) a. Monad m => a -> m a
return Located Token
loc { thing :: String
thing = String
str }
_ -> Range -> String -> ParseM (Located String)
forall a. Range -> String -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
loc) "Expected a string literal"
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType rng :: Range
rng ty :: Type PName
ty =
case Type PName
ty of
TLocated t :: Type PName
t r :: 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 "Record types"
TTuple {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad "Tuple types"
TFun {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad "Function types"
TSeq {} -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad "Sequence types"
TBit -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad "Type bit"
TNum {} -> ParseM (Type PName)
ok
TChar {} -> ParseM (Type PName)
ok
TWild -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad "Wildcard types"
TUser {} -> ParseM (Type PName)
ok
TParens t :: 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 x :: 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]
++ " 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
mkEApp :: [Expr PName] -> Expr PName
mkEApp :: [Expr PName] -> Expr PName
mkEApp es :: [Expr PName]
es@(eLast :: Expr PName
eLast : _) = (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
eFirst :: Expr PName
eFirst : rest :: [Expr PName]
rest = [Expr PName] -> [Expr PName]
forall a. [a] -> [a]
reverse [Expr PName]
es
f :: Expr PName
f : xs :: [Expr PName]
xs = Expr PName -> [Expr PName] -> [Expr PName]
cvtTypeParams Expr PName
eFirst [Expr PName]
rest
cvtTypeParams :: Expr PName -> [Expr PName] -> [Expr PName]
cvtTypeParams e :: Expr PName
e [] = [Expr PName
e]
cvtTypeParams e :: Expr PName
e (p :: Expr PName
p : ps :: [Expr PName]
ps) =
case Expr PName -> Maybe [TypeInst PName]
toTypeParam Expr PName
p of
Just fs :: [TypeInst PName]
fs -> Expr PName -> [Expr PName] -> [Expr PName]
cvtTypeParams (Expr PName -> [TypeInst PName] -> Expr PName
forall n. Expr n -> [TypeInst n] -> Expr n
EAppT Expr PName
e [TypeInst PName]
fs) [Expr PName]
ps
Nothing -> Expr PName
e Expr PName -> [Expr PName] -> [Expr PName]
forall a. a -> [a] -> [a]
: Expr PName -> [Expr PName] -> [Expr PName]
cvtTypeParams Expr PName
p [Expr PName]
ps
toTypeParam :: Expr PName -> Maybe [TypeInst PName]
toTypeParam e :: Expr PName
e =
case Expr PName -> Expr PName
forall t. AddLoc t => t -> t
dropLoc Expr PName
e of
ETypeVal t :: Type PName
t -> case Type PName -> Type PName
forall t. AddLoc t => t -> t
dropLoc Type PName
t of
TRecord fs :: [Named (Type PName)]
fs -> [TypeInst PName] -> Maybe [TypeInst PName]
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 [TypeInst PName]
forall a. Maybe a
Nothing
_ -> Maybe [TypeInst PName]
forall a. Maybe a
Nothing
mkEApp es :: [Expr PName]
es = String -> [String] -> Expr PName
forall a. HasCallStack => String -> [String] -> a
panic "[Parser] mkEApp" ["Unexpected:", [Expr PName] -> String
forall a. Show a => a -> String
show [Expr PName]
es]
unOp :: Expr PName -> Expr PName -> Expr PName
unOp :: Expr PName -> Expr PName -> Expr PName
unOp f :: Expr PName
f x :: 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 x :: Expr PName
x f :: LPName
f y :: 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 r :: Range
r e1 :: Expr PName
e1 e2 :: Maybe (Expr PName)
e2 e3 :: 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 (e1' :: Expr PName
e1', t :: Type PName
t), Nothing, 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)
(Nothing, Just (e2' :: Expr PName
e2', t :: Type PName
t), 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)
(Nothing, Nothing, Just (e3' :: Expr PName
e3', t :: 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)
(Nothing, Nothing, 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
_ -> Range -> String -> ParseM (Expr PName)
forall a. Range -> String -> ParseM a
errorMessage Range
r "A sequence enumeration may have at most one element type annotation."
where
asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped (ELocated e :: Expr n
e _) = Expr n -> Maybe (Expr n, Type n)
asETyped Expr n
e
asETyped (ETyped e :: Expr n
e t :: 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 _ = 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 r :: Range
r e1 :: Expr PName
e1 e2 :: Maybe (Expr PName)
e2 e3 :: Expr PName
e3 t :: 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
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT r :: Range
r expr :: Expr PName
expr =
case Expr PName -> Maybe (Type PName)
translateExprToNumT Expr PName
expr of
Just t :: Type PName
t -> Type PName -> ParseM (Type PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
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 -> ParseM a) -> String -> ParseM a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ "The boundaries of .. sequences should be valid numeric types."
, "The expression `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr PName -> String
forall a. Show a => a -> String
show Expr PName
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "` is not."
]
anonRecord :: Maybe Range -> [Type PName] -> Type PName
anonRecord :: Maybe Range -> [Type PName] -> Type PName
anonRecord ~(Just r :: Range
r) ts :: [Type PName]
ts = [Named (Type PName)] -> Type PName
forall n. [Named (Type n)] -> Type n
TRecord ((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)
where noName :: Located Ident
noName = $WLocated :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Ident
thing = Text -> Ident
mkIdent (String -> Text
T.pack "") }
toField :: a -> Named a
toField t :: 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 String) -> ExportType -> Decl PName -> TopDecl PName
exportDecl :: Maybe (Located String) -> ExportType -> Decl PName -> TopDecl PName
exportDecl mbDoc :: Maybe (Located String)
mbDoc e :: ExportType
e d :: Decl PName
d = TopLevel (Decl PName) -> TopDecl PName
forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel :: forall a. ExportType -> Maybe (Located String) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
e
, tlDoc :: Maybe (Located String)
tlDoc = Maybe (Located String)
mbDoc
, tlValue :: Decl PName
tlValue = Decl PName
d }
exportNewtype :: ExportType -> Maybe (Located String) -> Newtype PName ->
TopDecl PName
exportNewtype :: ExportType
-> Maybe (Located String) -> Newtype PName -> TopDecl PName
exportNewtype e :: ExportType
e d :: Maybe (Located String)
d n :: Newtype PName
n = TopLevel (Newtype PName) -> TopDecl PName
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel :: forall a. ExportType -> Maybe (Located String) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
e
, tlDoc :: Maybe (Located String)
tlDoc = Maybe (Located String)
d
, tlValue :: Newtype PName
tlValue = Newtype PName
n }
mkParFun :: Maybe (Located String) ->
Located PName ->
Schema PName ->
TopDecl PName
mkParFun :: Maybe (Located String) -> LPName -> Schema PName -> TopDecl PName
mkParFun mbDoc :: Maybe (Located String)
mbDoc n :: LPName
n s :: Schema PName
s = ParameterFun PName -> TopDecl PName
forall name. ParameterFun name -> TopDecl name
DParameterFun ParameterFun :: forall name.
Located name
-> Schema name -> Maybe String -> Maybe Fixity -> ParameterFun name
ParameterFun { pfName :: LPName
pfName = LPName
n
, pfSchema :: Schema PName
pfSchema = Schema PName
s
, pfDoc :: Maybe String
pfDoc = Located String -> String
forall a. Located a -> a
thing (Located String -> String)
-> Maybe (Located String) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located String)
mbDoc
, pfFixity :: Maybe Fixity
pfFixity = Maybe Fixity
forall a. Maybe a
Nothing
}
mkParType :: Maybe (Located String) ->
Located PName ->
Located Kind ->
ParseM (TopDecl PName)
mkParType :: Maybe (Located String)
-> LPName -> Located Kind -> ParseM (TopDecl PName)
mkParType mbDoc :: Maybe (Located String)
mbDoc n :: LPName
n k :: 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
$ \_ _ s :: 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
+ 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
$WParameterType :: forall name.
Located name
-> Kind
-> Maybe String
-> 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 String
ptDoc = Located String -> String
forall a. Located a -> a
thing (Located String -> String)
-> Maybe (Located String) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located String)
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 e :: 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 d :: 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 t :: 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 n :: 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 td :: TopDecl name
td@Include{} = TopDecl name
td
change (DParameterType {}) = String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic "changeExport" ["private type parameter?"]
change (DParameterFun {}) = String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic "changeExport" ["private value parameter?"]
change (DParameterConstraint {}) =
String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic "changeExport" ["private type constraint parameter?"]
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst x :: 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 } k :: 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 "`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 ln :: LPName
ln ps :: [TParam PName]
ps b :: 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) "`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 ln :: LPName
ln ps :: [TParam PName]
ps b :: 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) "`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 rng :: Range
rng k :: Integer
k p :: Integer
p
| Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 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
== 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 "Invalid polynomial coefficient"
mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly :: Range -> [(Bool, Integer)] -> ParseM (Expr PName)
mkPoly rng :: Range
rng terms :: [(Bool, Integer)]
terms = Integer -> [Int] -> ParseM (Expr PName)
forall n. Integer -> [Int] -> ParseM (Expr n)
mk 0 ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a. Num a => Integer -> a
fromInteger [Integer]
bits)
where
w :: Int
w = case [(Bool, Integer)]
terms of
[] -> 0
_ -> 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((Bool, Integer) -> Int) -> [(Bool, Integer)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int)
-> ((Bool, Integer) -> Integer) -> (Bool, Integer) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, Integer) -> Integer
forall a b. (a, b) -> b
snd) [(Bool, Integer)]
terms)
bits :: [Integer]
bits = [ Integer
n | (True,n :: Integer
n) <- [(Bool, Integer)]
terms ]
mk :: Integer -> [Int] -> ParseM (Expr n)
mk res :: Integer
res [] = Expr n -> ParseM (Expr n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr n -> ParseM (Expr n)) -> Expr n -> ParseM (Expr n)
forall a b. (a -> b) -> a -> b
$ Literal -> Expr n
forall n. Literal -> Expr n
ELit (Literal -> Expr n) -> Literal -> Expr n
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
res (Int -> NumInfo
PolyLit Int
w)
mk res :: Integer
res (n :: Int
n : ns :: [Int]
ns)
| Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
res Int
n = Range -> String -> ParseM (Expr n)
forall a. Range -> String -> ParseM a
errorMessage Range
rng
("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 n)
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 f :: LPName
f ps :: [Pattern PName]
ps e :: 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 String
-> 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 String
bDoc = Maybe String
forall a. Maybe a
Nothing
}
mkIndexedDecl ::
LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl :: LPName
-> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl f :: LPName
f (ps :: [Pattern PName]
ps, ixs :: [Pattern PName]
ixs) e :: 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 String
-> 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 String
bDoc = Maybe String
forall a. Maybe a
Nothing
}
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 (ps :: [Pattern PName]
ps, ixs :: [Pattern PName]
ixs) body :: 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 = [Pattern PName] -> Expr PName -> Expr PName
forall n. [Pattern n] -> Expr n -> Expr n
EFun ([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 pats :: [Pattern PName]
pats body :: 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 (\pat :: Pattern PName
pat e :: Expr PName
e -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EGenerate ([Pattern PName] -> Expr PName -> Expr PName
forall n. [Pattern n] -> Expr n -> Expr n
EFun [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 ifThens :: [(Expr PName, Expr PName)]
ifThens theElse :: 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 (cond :: Expr n
cond, doexpr :: Expr n
doexpr) elseExpr :: 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 String) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl :: Maybe (Located String) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl mbDoc :: Maybe (Located String)
mbDoc ln :: LPName
ln sig :: Schema PName
sig =
[ Maybe (Located String) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located String)
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 String
-> 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 String
bDoc = Maybe String
forall a. Maybe a
Nothing
}
, Maybe (Located String) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located String)
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 String) ->
Schema PName ->
Located Kind ->
ParseM [TopDecl PName]
mkPrimTypeDecl :: Maybe (Located String)
-> Schema PName -> Located Kind -> ParseM [TopDecl PName]
mkPrimTypeDecl mbDoc :: Maybe (Located String)
mbDoc (Forall as :: [TParam PName]
as qs :: [Prop PName]
qs st :: Type PName
st ~(Just schema_rng :: Range
schema_rng)) finK :: 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 (n :: LPName
n,xs :: [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 "Repeated parameterms."
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 v :: 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 (k :: TParam PName
k,tp :: Kind
tp) -> (TParam PName, Kind) -> ParseM (TParam PName, Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam PName
k,Kind
tp)
Nothing ->
Range -> String -> ParseM (TParam PName, Kind)
forall a. Range -> String -> ParseM a
errorMessage
(LPName -> Range
forall a. Located a -> Range
srcRange LPName
v)
("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)))
(as' :: [TParam PName]
as',ins :: [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 "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 String) -> a -> TopLevel a
TopLevel
{ tlExport :: ExportType
tlExport = ExportType
Public
, tlDoc :: Maybe (Located String)
tlDoc = Maybe (Located String)
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
}
}
]
Nothing -> Range -> String -> ParseM [TopDecl PName]
forall a. Range -> String -> ParseM a
errorMessage Range
schema_rng "Invalid primitive signature"
where
splitT :: Range -> Type a -> Maybe (Located a, [Located a])
splitT r :: Range
r ty :: Type a
ty = case Type a
ty of
TLocated t :: Type a
t r1 :: Range
r1 -> Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r1 Type a
t
TUser n :: a
n ts :: [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 $WLocated :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n } [Type a]
ts
TInfix t1 :: Type a
t1 n :: Located a
n _ t2 :: 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]
_ -> Maybe (Located a, [Located a])
forall a. Maybe a
Nothing
mkT :: Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT r :: Range
r n :: a
n ts :: [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 r :: Range
r ty :: Type a
ty = case Type a
ty of
TLocated t :: Type a
t r1 :: Range
r1 -> Range -> Type a -> Maybe (Located a)
isVar Range
r1 Type a
t
TUser n :: a
n [] -> Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just $WLocated :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n }
_ -> Maybe (Located a)
forall a. Maybe a
Nothing
distinct :: [a] -> Bool
distinct xs :: [a]
xs = case [a]
xs of
[] -> Bool
True
x :: a
x : ys :: [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 tp :: TParam n
tp = case TParam n -> Maybe Kind
forall n. TParam n -> Maybe Kind
tpKind TParam n
tp of
Just k :: 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))
Nothing ->
case TParam n -> Maybe Range
forall n. TParam n -> Maybe Range
tpRange TParam n
tp of
Just r :: Range
r -> Range -> String -> ParseM (n, (TParam n, Kind))
forall a. Range -> String -> ParseM a
errorMessage Range
r "Parameters need a kind annotation"
Nothing -> String -> [String] -> ParseM (n, (TParam n, Kind))
forall a. HasCallStack => String -> [String] -> a
panic "mkPrimTypeDecl"
[ "Missing range on schema parameter." ]
mkDoc :: Located Text -> Located String
mkDoc :: Located Text -> Located String
mkDoc ltxt :: Located Text
ltxt = Located Text
ltxt { thing :: String
thing = String
docStr }
where
docStr :: String
docStr = [String] -> String
unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
([Text] -> [String]) -> [Text] -> [String]
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 x :: Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ("/* \r\n\t" :: String)
prefixDroppable :: Char -> Bool
prefixDroppable x :: Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ("* \r\n\t" :: String)
trimFront :: [Text] -> [Text]
trimFront [] = []
trimFront (l :: Text
l:ls :: [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 [t :: Text
t] = [(Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
t]
dropPrefix ts :: [Text]
ts@(l :: Text
l:ls :: [Text]
ls) =
case Text -> Maybe (Char, Text)
T.uncons Text
l of
Just (c :: Char
c,_) | 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 1) [Text]
ts)
_ -> [Text]
ts
where
commonPrefix :: Char -> Text -> Bool
commonPrefix c :: Char
c t :: Text
t =
case Text -> Maybe (Char, Text)
T.uncons Text
t of
Just (c' :: Char
c',_) -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'
Nothing -> Bool
False
distrLoc :: Located [a] -> [Located a]
distrLoc :: Located [a] -> [Located a]
distrLoc x :: Located [a]
x = [ $WLocated :: 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 ty :: Type PName
ty =
case Type PName
ty of
TLocated t :: Type PName
t r :: 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
_ -> String -> [String] -> ParseM (Located [Prop PName])
forall a. HasCallStack => String -> [String] -> a
panic "Parser" [ "Invalid type given to mkProp"
, "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 r :: Range
r t :: 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 ts :: [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 t' :: Type n
t' -> Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t'
TLocated t' :: Type n
t' r' :: 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
TWild -> ParseM [Prop n]
forall a. ParseM a
err
TRecord{} -> 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 "Invalid constraint"
mkModule :: Located ModName ->
([Located Import], [TopDecl PName]) ->
Module PName
mkModule :: Located ModName
-> ([Located Import], [TopDecl PName]) -> Module PName
mkModule nm :: Located ModName
nm (is :: [Located Import]
is,ds :: [TopDecl PName]
ds) = $WModule :: forall name.
Located ModName
-> Maybe (Located ModName)
-> [Located Import]
-> [TopDecl name]
-> Module name
Module { mName :: Located ModName
mName = Located ModName
nm
, mInstance :: Maybe (Located ModName)
mInstance = Maybe (Located ModName)
forall a. Maybe a
Nothing
, mImports :: [Located Import]
mImports = [Located Import]
is
, mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds
}
mkAnonymousModule :: ([Located Import], [TopDecl PName]) ->
Module PName
mkAnonymousModule :: ([Located Import], [TopDecl PName]) -> Module PName
mkAnonymousModule = Located ModName
-> ([Located Import], [TopDecl PName]) -> Module PName
mkModule $WLocated :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
emptyRange
, thing :: ModName
thing = [Text] -> ModName
mkModName [String -> Text
T.pack "Main"]
}
mkModuleInstance :: Located ModName ->
Located ModName ->
([Located Import], [TopDecl PName]) ->
Module PName
mkModuleInstance :: Located ModName
-> Located ModName
-> ([Located Import], [TopDecl PName])
-> Module PName
mkModuleInstance nm :: Located ModName
nm fun :: Located ModName
fun (is :: [Located Import]
is,ds :: [TopDecl PName]
ds) =
$WModule :: forall name.
Located ModName
-> Maybe (Located ModName)
-> [Located Import]
-> [TopDecl name]
-> Module 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
, mImports :: [Located Import]
mImports = [Located Import]
is
, mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds
}
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField h :: UpdHow
h ls :: [Located Selector]
ls e :: Expr PName
e) =
case (UpdHow
h,[Located Selector]
ls) of
(UpdSet, [l :: Located Selector
l]) | RecordSel i :: Ident
i 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 }
_ -> 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))
"Invalid record field. Perhaps you meant to update a record?"
selExprToSels :: Expr PName -> ParseM [Located Selector]
selExprToSels :: Expr PName -> ParseM [Located Selector]
selExprToSels e0 :: 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 "selExprToSels" ["Missing location?"]
go :: Range -> Expr PName -> ParseM [Located Selector]
go loc :: Range
loc expr :: Expr PName
expr =
case Expr PName
expr of
ELocated e1 :: Expr PName
e1 r :: Range
r -> Range -> Expr PName -> ParseM [Located Selector]
go Range
r Expr PName
e1
ESel e2 :: Expr PName
e2 s :: 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 ($WLocated :: 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 l :: Ident
l) ->
[Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ $WLocated :: 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 n :: Integer
n _) ->
[Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ $WLocated :: 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 } ]
_ -> Range -> String -> ParseM [Located Selector]
forall a. Range -> String -> ParseM a
errorMessage Range
loc "Invalid label in record update."