{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where
import qualified Data.Text as Text
import Data.Char(isAlphaNum)
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Data.Maybe(mapMaybe)
import Data.List(foldl')
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard,msum)
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
, identAnonArg, identAnonIfaceMod
, modNameArg, modNameIfaceMod
, modNameToText, modNameIsNormal
, modNameToNormalModName
, unpackIdent
)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Cryptol.Utils.RecordMap
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString :: forall a. Config -> ParseM a -> FilePath -> Either ParseError a
parseString Config
cfg ParseM a
p FilePath
cs = forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p (FilePath -> Text
T.pack FilePath
cs)
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse :: forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p Text
cs = case forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
p Config
cfg Position
eofPos S { sPrevTok :: Maybe (Located Token)
sPrevTok = forall a. Maybe a
Nothing
, sTokens :: [Located Token]
sTokens = [Located Token]
toks
, sNextTyParamNum :: Int
sNextTyParamNum = Int
0
} of
Left ParseError
err -> forall a b. a -> Either a b
Left ParseError
err
Right (a
a,S
_) -> 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 { forall a.
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 :: forall a. (Located Token -> ParseM a) -> ParseM a
lexerP Located Token -> ParseM a
k = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P 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 ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Range -> [FilePath] -> ParseError
HappyErrorMsg (forall a. Located a -> Range
srcRange Located Token
t) forall a b. (a -> b) -> a -> b
$
[case TokenErr
e of
TokenErr
UnterminatedComment -> FilePath
"unterminated comment"
TokenErr
UnterminatedString -> FilePath
"unterminated string"
TokenErr
UnterminatedChar -> FilePath
"unterminated character"
TokenErr
InvalidString -> FilePath
"invalid string literal: " forall a. [a] -> [a] -> [a]
++
Text -> FilePath
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
InvalidChar -> FilePath
"invalid character literal: " forall a. [a] -> [a] -> [a]
++
Text -> FilePath
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
LexicalError -> FilePath
"unrecognized character: " forall a. [a] -> [a] -> [a]
++
Text -> FilePath
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
MalformedLiteral -> FilePath
"malformed literal: " forall a. [a] -> [a] -> [a]
++
Text -> FilePath
T.unpack (Token -> Text
tokenText Token
it)
TokenErr
MalformedSelector -> FilePath
"malformed selector: " forall a. [a] -> [a] -> [a]
++
Text -> FilePath
T.unpack (Token -> Text
tokenText Token
it)
InvalidIndentation TokenT
c -> FilePath
"invalid indentation, unmatched " forall a. [a] -> [a] -> [a]
++
case TokenT
c of
Sym TokenSym
CurlyR -> FilePath
"{ ... } "
Sym TokenSym
ParenR -> FilePath
"( ... )"
Sym TokenSym
BracketR -> FilePath
"[ ... ]"
TokenT
_ -> forall a. Show a => a -> FilePath
show TokenT
c
]
where it :: Token
it = forall a. Located a -> a
thing Located Token
t
Located Token
t : [Located Token]
more -> 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 = forall a. a -> Maybe a
Just Located Token
t, sTokens :: [Located Token]
sTokens = [Located Token]
more }
[] -> forall a b. a -> Either a b
Left (FilePath -> Position -> ParseError
HappyOutOfTokens (Config -> FilePath
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 -> ShowS
[ParseError] -> ShowS
ParseError -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> FilePath
$cshow :: ParseError -> FilePath
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show, 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 -> ()
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 FilePath
path Located Token
ltok)
| Err TokenErr
_ <- Token -> TokenT
tokenType Token
tok =
FilePath -> Doc
text FilePath
"Parse error at" Doc -> Doc -> Doc
<+>
FilePath -> Doc
text FilePath
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> 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
<+>
FilePath -> Doc
text FilePath
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> 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 =
FilePath -> Doc
text FilePath
"Parse error at" Doc -> Doc -> Doc
<+>
FilePath -> Doc
text FilePath
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
indent Int
2 (FilePath -> Doc
text FilePath
"unexpected:" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Token
tok)
where
pos :: Position
pos = Range -> Position
from (forall a. Located a -> Range
srcRange Located Token
ltok)
tok :: Token
tok = forall a. Located a -> a
thing Located Token
ltok
ppError (HappyOutOfTokens FilePath
path Position
pos) =
FilePath -> Doc
text FilePath
"Unexpected end of file at:" Doc -> Doc -> Doc
<+>
FilePath -> Doc
text FilePath
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> forall a. PP a => a -> Doc
pp Position
pos
ppError (HappyErrorMsg Range
p [FilePath]
xs) = FilePath -> Doc
text FilePath
"Parse error at" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Range
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Doc
text [FilePath]
xs))
ppError (HappyUnexpected FilePath
path Maybe (Located Token)
ltok FilePath
e) =
Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$
[ FilePath -> Doc
text FilePath
"Parse error at" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma ]
forall a. [a] -> [a] -> [a]
++ [Doc]
unexp
forall a. [a] -> [a] -> [a]
++ [Doc
"expected:" Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
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
<+> FilePath -> Doc
text (Text -> FilePath
T.unpack (Token -> Text
tokenText (forall a. Located a -> a
thing Located Token
t)))]
, Range -> Position
from (forall a. Located a -> Range
srcRange Located Token
t)
)
instance Functor ParseM where
fmap :: forall a b. (a -> b) -> ParseM a -> ParseM b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative ParseM where
pure :: forall a. a -> ParseM a
pure a
a = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
_ Position
_ S
s -> forall a b. b -> Either a b
Right (a
a,S
s))
<*> :: forall a 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 :: forall a. a -> ParseM a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
ParseM a
m >>= :: forall a b. ParseM a -> (a -> ParseM b) -> ParseM b
>>= a -> ParseM b
k = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
cfg Position
p S
s1 -> case 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 -> forall a b. a -> Either a b
Left ParseError
e
Right (a
a,S
s2) -> 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 :: forall a. FilePath -> ParseM a
fail FilePath
s = forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] fail" [FilePath
s]
happyError :: ParseM a
happyError :: forall a. ParseM a
happyError = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P 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 -> forall a b. a -> Either a b
Left (FilePath -> Located Token -> ParseError
HappyError (Config -> FilePath
cfgSource Config
cfg) Located Token
t)
Maybe (Located Token)
Nothing ->
forall a b. a -> Either a b
Left (Range -> [FilePath] -> ParseError
HappyErrorMsg Range
emptyRange [FilePath
"Parse error at the beginning of the file"])
errorMessage :: Range -> [String] -> ParseM a
errorMessage :: forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath]
xs = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> forall a b. a -> Either a b
Left (Range -> [FilePath] -> ParseError
HappyErrorMsg Range
r [FilePath]
xs)
customError :: String -> Located Token -> ParseM a
customError :: forall a. FilePath -> Located Token -> ParseM a
customError FilePath
x Located Token
t = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> forall a b. a -> Either a b
Left (Range -> [FilePath] -> ParseError
HappyErrorMsg (forall a. Located a -> Range
srcRange Located Token
t) [FilePath
x])
expected :: String -> ParseM a
expected :: forall a. FilePath -> ParseM a
expected FilePath
x = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
forall a b. a -> Either a b
Left (FilePath -> Maybe (Located Token) -> FilePath -> ParseError
HappyUnexpected (Config -> FilePath
cfgSource Config
cfg) (S -> Maybe (Located Token)
sPrevTok S
s) FilePath
x)
mkModName :: [Text] -> ModName
mkModName :: [Text] -> ModName
mkModName = [Text] -> ModName
packModName
mkModParamName :: Located (ImpName PName) -> Maybe (Located ModName) -> Ident
mkModParamName :: Located (ImpName PName) -> Maybe (Located ModName) -> Ident
mkModParamName Located (ImpName PName)
lsig Maybe (Located ModName)
qual =
case Maybe (Located ModName)
qual of
Maybe (Located ModName)
Nothing ->
case forall a. Located a -> a
thing Located (ImpName PName)
lsig of
ImpTop ModName
t
| ModName -> Bool
modNameIsNormal ModName
t -> FilePath -> Ident
packIdent (forall a. [a] -> a
last (ModName -> [FilePath]
modNameChunks ModName
t))
| Bool
otherwise -> Ident -> Ident
identAnonIfaceMod
forall a b. (a -> b) -> a -> b
$ FilePath -> Ident
packIdent
forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last
forall a b. (a -> b) -> a -> b
$ ModName -> [FilePath]
modNameChunks
forall a b. (a -> b) -> a -> b
$ ModName -> ModName
modNameToNormalModName ModName
t
ImpNested PName
nm ->
case PName
nm of
UnQual Ident
i -> Ident
i
Qual ModName
_ Ident
i -> Ident
i
NewName {} -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkModParamName" [FilePath
"Unexpected NewName",forall a. Show a => a -> FilePath
show Located (ImpName PName)
lsig]
Just Located ModName
m -> FilePath -> Ident
packIdent (forall a. [a] -> a
last (ModName -> [FilePath]
modNameChunks (forall a. Located a -> a
thing Located ModName
m)))
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 = forall n.
[TParam n] -> [Prop n] -> Type n -> Maybe Range -> Schema n
Forall [TParam PName]
xs [Prop PName]
ps Type PName
t forall a. Maybe a
Nothing
getName :: Located Token -> PName
getName :: Located Token -> PName
getName Located Token
l = case forall a. Located a -> a
thing Located Token
l of
Token (Ident [] Text
x) Text
_ -> Ident -> PName
mkUnqual (Text -> Ident
mkIdent Text
x)
Token
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] getName" [FilePath
"not an Ident:", forall a. Show a => a -> FilePath
show Located Token
l]
getNum :: Located Token -> Integer
getNum :: Located Token -> Integer
getNum Located Token
l = case forall a. Located a -> a
thing Located Token
l of
Token (Num Integer
x Int
_ Int
_) Text
_ -> Integer
x
Token (ChrLit Char
x) Text
_ -> forall a. Integral a => a -> Integer
toInteger (forall a. Enum a => a -> Int
fromEnum Char
x)
Token
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] getNum" [FilePath
"not a number:", forall a. Show a => a -> FilePath
show Located Token
l]
getChr :: Located Token -> Char
getChr :: Located Token -> Char
getChr Located Token
l = case forall a. Located a -> a
thing Located Token
l of
Token (ChrLit Char
x) Text
_ -> Char
x
Token
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] getChr" [FilePath
"not a char:", forall a. Show a => a -> FilePath
show Located Token
l]
getStr :: Located Token -> String
getStr :: Located Token -> FilePath
getStr Located Token
l = case forall a. Located a -> a
thing Located Token
l of
Token (StrLit FilePath
x) Text
_ -> FilePath
x
Token
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] getStr" [FilePath
"not a string:", forall a. Show a => a -> FilePath
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 forall a. Eq a => a -> a -> Bool
== Int
2 = forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
BinLit Text
txt Int
digs)
| Int
base forall a. Eq a => a -> a -> Bool
== Int
8 = forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
OctLit Text
txt Int
digs)
| Int
base forall a. Eq a => a -> a -> Bool
== Int
10 = forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> NumInfo
DecLit Text
txt)
| Int
base forall a. Eq a => a -> a -> Bool
== Int
16 = forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
HexLit Text
txt Int
digs)
numLit Token
x = forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] numLit" [FilePath
"invalid numeric literal", forall a. Show a => a -> FilePath
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 forall a. Eq a => a -> a -> Bool
== Int
2 -> forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
BinFrac forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
| Int
base forall a. Eq a => a -> a -> Bool
== Int
8 -> forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
OctFrac forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
| Int
base forall a. Eq a => a -> a -> Bool
== Int
10 -> forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
DecFrac forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
| Int
base forall a. Eq a => a -> a -> Bool
== Int
16 -> forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
HexFrac forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
TokenT
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[Parser] fracLit" [ FilePath
"Invalid fraction", forall a. Show a => a -> FilePath
show Token
tok ]
intVal :: Located Token -> ParseM Integer
intVal :: Located Token -> ParseM Integer
intVal Located Token
tok =
case Token -> TokenT
tokenType (forall a. Located a -> a
thing Located Token
tok) of
Num Integer
x Int
_ Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
TokenT
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange Located Token
tok) [FilePath
"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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
l forall a. Ord a => a -> a -> Bool
>= Integer
1 Bool -> Bool -> Bool
&& Integer
l forall a. Ord a => a -> a -> Bool
<= Integer
100)
(forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange Located Token
tok) [FilePath
"Fixity levels must be between 1 and 100"])
forall (m :: * -> *) a. Monad m => a -> m a
return (forall name. Fixity -> [Located name] -> Decl name
DFixity (Assoc -> Int -> Fixity
Fixity Assoc
assoc (forall a. Num a => Integer -> a
fromInteger Integer
l)) [LPName]
qns)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit :: Located Token -> ParseM (Located FilePath)
fromStrLit Located Token
loc = case Token -> TokenT
tokenType (forall a. Located a -> a
thing Located Token
loc) of
StrLit FilePath
str -> forall (m :: * -> *) a. Monad m => a -> m a
return Located Token
loc { thing :: FilePath
thing = FilePath
str }
TokenT
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange Located Token
loc) [FilePath
"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 {} -> forall a. FilePath -> ParseM a
bad FilePath
"Record types"
TTyApp {} -> forall a. FilePath -> ParseM a
bad FilePath
"Explicit type application"
TTuple {} -> forall a. FilePath -> ParseM a
bad FilePath
"Tuple types"
TFun {} -> forall a. FilePath -> ParseM a
bad FilePath
"Function types"
TSeq {} -> forall a. FilePath -> ParseM a
bad FilePath
"Sequence types"
Type PName
TBit -> forall a. FilePath -> ParseM a
bad FilePath
"Type bit"
TNum {} -> ParseM (Type PName)
ok
TChar {} -> ParseM (Type PName)
ok
Type PName
TWild -> forall a. FilePath -> ParseM a
bad FilePath
"Wildcard types"
TUser {} -> ParseM (Type PName)
ok
TParens Type PName
t Maybe Kind
mb -> case Maybe Kind
mb of
Maybe Kind
Nothing -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
t
Just Kind
_ -> forall a. FilePath -> ParseM a
bad FilePath
"kind annotation"
TInfix{} -> ParseM (Type PName)
ok
where bad :: FilePath -> ParseM a
bad FilePath
x = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
rng [FilePath
x forall a. [a] -> [a] -> [a]
++ FilePath
" cannot be demoted."]
ok :: ParseM (Type PName)
ok = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall b a.
AddLoc b =>
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
_)) -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
nmRng [FilePath
"Record has repeated field: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp Ident
nm)]
Right RecordMap Ident (Range, a)
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> 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 = 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 = forall a b. (a -> b) -> [a] -> [b]
map (\ (Named (Located Range
r Ident
nm) a
x) -> (Ident
nm,(Range
r,a
x))) (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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
eFirst,Expr PName
eLast) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f [Expr PName]
xs)
where
Expr PName
eFirst :| [Expr PName]
rest = 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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr PName
e 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 forall a. Maybe a
Nothing of
Maybe ([TypeInst PName], [Selector], Maybe Range)
Nothing -> forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Expr PName
e 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 forall {n}. Expr n -> Bool
checkAppExpr Expr PName
e then
let e' :: Expr PName
e' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall n. Expr n -> Selector -> Expr n
ESel) (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 (forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e) Maybe Range
rng of
Just Range
r -> 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
forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. a -> Maybe a -> a
fromMaybe Range
emptyRange (forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e))
[ FilePath
"Explicit type applications can only be applied to named values."
, FilePath
"Unexpected: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (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 (forall a. a -> Maybe a
Just Range
rng))
ETypeVal Type PName
t -> 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
sforall a. a -> [a] -> [a]
:[Selector]
ss,Maybe Range
r) ) 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
_ -> 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 (forall a. a -> Maybe a
Just Range
rng))
TTyApp [Named (Type PName)]
fs -> forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map Named (Type PName) -> TypeInst PName
mkTypeInst [Named (Type PName)]
fs, [], Maybe Range
mr)
Type PName
_ -> 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 = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
f,Expr PName
x) forall a b. (a -> b) -> a -> b
$ 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 = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
x,Expr PName
y) forall a b. (a -> b) -> a -> b
$ 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 (forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, forall n. Expr n -> Maybe (Expr n, Type n)
asETyped forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expr PName)
e2, 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 (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 (forall a. a -> Maybe a
Just Expr PName
e2') Expr PName
e3 (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' (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 forall a. Maybe a
Nothing
(Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
Maybe (Expr PName, Type PName))
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"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 (forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, 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 (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 (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' (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 forall a. Maybe a
Nothing Bool
isStrictBound
(Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
Maybe (Expr PName, Type PName))
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"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 =
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToBy Bool
isStrictBound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
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
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
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 (forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, 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 (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 (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' (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 forall a. Maybe a
Nothing Bool
isStrictBound
(Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
Maybe (Expr PName, Type PName))
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"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 =
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToDownBy Bool
isStrictBound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
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
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
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t
asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped :: forall n. Expr n -> Maybe (Expr n, Type n)
asETyped (ELocated Expr n
e Range
_) = forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr n
e
asETyped (ETyped Expr n
e Type n
t) = forall a. a -> Maybe a
Just (Expr n
e, Type n
t)
asETyped Expr 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 =
forall n.
Type n -> Maybe (Type n) -> Type n -> Maybe (Type n) -> Expr n
EFromTo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
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
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2 of
Just (Expr PName, Type PName)
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"The exclusive upper bound of an enumeration may not have a type annotation."]
Maybe (Expr PName, Type PName)
Nothing ->
case 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 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 (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 =
forall n. Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToLessThan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
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
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
Maybe (Type PName)
Nothing -> forall a. ParseM a
bad
where
bad :: ParseM a
bad = forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. a -> Maybe a -> a
fromMaybe Range
r (forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
expr))
[ FilePath
"The boundaries of .. sequences should be valid numeric types."
, FilePath
"The expression `" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp Expr PName
expr) forall a. [a] -> [a] -> [a]
++ FilePath
"` is not."
]
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp ~(Just Range
r) [Type PName]
ts = forall n. Type n -> Range -> Type n
TLocated (forall n. [Named (Type n)] -> Type n
TTyApp (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. a -> Named a
toField [Type PName]
ts)) Range
r
where noName :: Located Ident
noName = Located { srcRange :: Range
srcRange = Range
r, thing :: Ident
thing = Text -> Ident
mkIdent (FilePath -> Text
T.pack FilePath
"") }
toField :: a -> Named a
toField a
t = 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 = forall name. TopLevel (Decl name) -> TopDecl name
Decl 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 = forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype 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 = forall name. TopLevel (NestedModule name) -> TopDecl name
DModule 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 ->
ParamDecl PName
mkParFun :: Maybe (Located Text) -> LPName -> Schema PName -> ParamDecl PName
mkParFun Maybe (Located Text)
mbDoc LPName
n Schema PName
s = forall name. ParameterFun name -> ParamDecl name
DParameterFun ParameterFun { pfName :: LPName
pfName = LPName
n
, pfSchema :: Schema PName
pfSchema = Schema PName
s
, pfDoc :: Maybe Text
pfDoc = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
, pfFixity :: Maybe Fixity
pfFixity = forall a. Maybe a
Nothing
}
mkParType :: Maybe (Located Text) ->
Located PName ->
Located Kind ->
ParseM (ParamDecl PName)
mkParType :: Maybe (Located Text)
-> LPName -> Located Kind -> ParseM (ParamDecl PName)
mkParType Maybe (Located Text)
mbDoc LPName
n Located Kind
k =
do Int
num <- forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
s -> let nu :: Int
nu = S -> Int
sNextTyParamNum S
s
in forall a b. b -> Either a b
Right (Int
nu, S
s { sNextTyParamNum :: Int
sNextTyParamNum = Int
nu forall a. Num a => a -> a -> a
+ Int
1 })
forall (m :: * -> *) a. Monad m => a -> m a
return (forall name. ParameterType name -> ParamDecl name
DParameterType
ParameterType { ptName :: LPName
ptName = LPName
n
, ptKind :: Kind
ptKind = forall a. Located a -> a
thing Located Kind
k
, ptDoc :: Maybe Text
ptDoc = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
, ptFixity :: Maybe Fixity
ptFixity = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall {name}. TopDecl name -> TopDecl name
change
where
change :: TopDecl name -> TopDecl name
change TopDecl name
decl =
case TopDecl name
decl of
Decl TopLevel (Decl name)
d -> forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel (Decl name)
d { tlExport :: ExportType
tlExport = ExportType
e }
DPrimType TopLevel (PrimType name)
t -> forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType name)
t { tlExport :: ExportType
tlExport = ExportType
e }
TDNewtype TopLevel (Newtype name)
n -> forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel (Newtype name)
n { tlExport :: ExportType
tlExport = ExportType
e }
DModule TopLevel (NestedModule name)
m -> forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule name)
m { tlExport :: ExportType
tlExport = ExportType
e }
DModParam {} -> TopDecl name
decl
Include{} -> TopDecl name
decl
DImport{} -> TopDecl name
decl
DParamDecl{} -> TopDecl name
decl
DInterfaceConstraint {} -> TopDecl name
decl
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst Named (Type PName)
x | Ident -> Bool
nullIdent (forall a. Located a -> a
thing (forall a. Named a -> Located Ident
name Named (Type PName)
x)) = forall name. Type name -> TypeInst name
PosInst (forall a. Named a -> a
value Named (Type PName)
x)
| Bool
otherwise = 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 forall a. Eq a => a -> a -> Bool
== Ident
widthIdent = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
rng [FilePath
"`width` is not a valid type parameter name."]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. n -> Maybe Kind -> Maybe Range -> TParam n
TParam (Ident -> PName
mkUnqual Ident
n) Maybe Kind
k (forall a. a -> Maybe a
Just Range
rng))
mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkTySyn Type PName
thead Type PName
tdef =
do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. TySyn name -> Decl name
DType (forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn LPName
nm forall a. Maybe a
Nothing [TParam PName]
params Type PName
tdef))
mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkPropSyn Type PName
thead Type PName
tdef =
do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
[Prop PName]
ps <- forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
tdef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. PropSyn name -> Decl name
DProp (forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn LPName
nm forall a. Maybe a
Nothing [TParam PName]
params [Prop PName]
ps))
mkNewtype ::
Type PName ->
Located (RecordMap Ident (Range, Type PName)) ->
ParseM (Newtype PName)
mkNewtype :: Type PName
-> Located (RecordMap Ident (Range, Type PName))
-> ParseM (Newtype PName)
mkNewtype Type PName
thead Located (RecordMap Ident (Range, Type PName))
def =
do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name.
Located name
-> [TParam name] -> name -> Rec (Type name) -> Newtype name
Newtype LPName
nm [TParam PName]
params (forall a. Located a -> a
thing LPName
nm) (forall a. Located a -> a
thing Located (RecordMap Ident (Range, Type PName))
def))
typeToDecl :: Type PName -> ParseM (Located PName, [TParam PName])
typeToDecl :: Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
ty0 =
case Type PName
ty0 of
TLocated Type PName
ty Range
loc -> Range -> Type PName -> ParseM (LPName, [TParam PName])
goD Range
loc Type PName
ty
Type PName
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"typeToDecl" [FilePath
"Type location is missing."]
where
bad :: Range -> ParseM a
bad Range
loc = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [FilePath
"Invalid type declaration"]
badP :: Range -> ParseM a
badP Range
loc = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [FilePath
"Invalid declaration parameter"]
goN :: Range -> PName -> ParseM ()
goN Range
loc PName
n =
case PName
n of
UnQual {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
PName
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [FilePath
"Invalid declaration name"]
goP :: Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
ty =
case Type PName
ty of
TLocated Type PName
ty1 Range
loc1 -> Range -> Type PName -> ParseM (TParam PName)
goP Range
loc1 Type PName
ty1
TUser PName
f [] ->
do Range -> PName -> ParseM ()
goN Range
loc PName
f
forall (f :: * -> *) a. Applicative f => a -> f a
pure TParam { tpName :: PName
tpName = PName
f, tpKind :: Maybe Kind
tpKind = forall a. Maybe a
Nothing, tpRange :: Maybe Range
tpRange = forall a. a -> Maybe a
Just Range
loc }
TParens Type PName
t Maybe Kind
mb ->
case Maybe Kind
mb of
Maybe Kind
Nothing -> forall {a}. Range -> ParseM a
badP Range
loc
Just Kind
k ->
do TParam PName
p <- Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
t
case forall n. TParam n -> Maybe Kind
tpKind TParam PName
p of
Maybe Kind
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TParam PName
p { tpKind :: Maybe Kind
tpKind = forall a. a -> Maybe a
Just Kind
k }
Just {} -> forall {a}. Range -> ParseM a
badP Range
loc
TInfix {} -> forall {a}. Range -> ParseM a
badP Range
loc
TUser {} -> forall {a}. Range -> ParseM a
badP Range
loc
TFun {} -> forall {a}. Range -> ParseM a
badP Range
loc
TSeq {} -> forall {a}. Range -> ParseM a
badP Range
loc
TBit {} -> forall {a}. Range -> ParseM a
badP Range
loc
TNum {} -> forall {a}. Range -> ParseM a
badP Range
loc
TChar {} -> forall {a}. Range -> ParseM a
badP Range
loc
TRecord {} -> forall {a}. Range -> ParseM a
badP Range
loc
TWild {} -> forall {a}. Range -> ParseM a
badP Range
loc
TTyApp {} -> forall {a}. Range -> ParseM a
badP Range
loc
TTuple {} -> forall {a}. Range -> ParseM a
badP Range
loc
goD :: Range -> Type PName -> ParseM (LPName, [TParam PName])
goD Range
loc Type PName
ty =
case Type PName
ty of
TLocated Type PName
ty1 Range
loc1 -> Range -> Type PName -> ParseM (LPName, [TParam PName])
goD Range
loc1 Type PName
ty1
TUser PName
f [Type PName]
ts ->
do Range -> PName -> ParseM ()
goN Range
loc PName
f
[TParam PName]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type PName -> ParseM (TParam PName)
goP Range
loc) [Type PName]
ts
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located { thing :: PName
thing = PName
f, srcRange :: Range
srcRange = Range
loc },[TParam PName]
ps)
TInfix Type PName
l LPName
f Fixity
_ Type PName
r ->
do Range -> PName -> ParseM ()
goN (forall a. Located a -> Range
srcRange LPName
f) (forall a. Located a -> a
thing LPName
f)
TParam PName
a <- Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
l
TParam PName
b <- Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LPName
f,[TParam PName
a,TParam PName
b])
TFun {} -> forall {a}. Range -> ParseM a
bad Range
loc
TSeq {} -> forall {a}. Range -> ParseM a
bad Range
loc
TBit {} -> forall {a}. Range -> ParseM a
bad Range
loc
TNum {} -> forall {a}. Range -> ParseM a
bad Range
loc
TChar {} -> forall {a}. Range -> ParseM a
bad Range
loc
TRecord {} -> forall {a}. Range -> ParseM a
bad Range
loc
TWild {} -> forall {a}. Range -> ParseM a
bad Range
loc
TTyApp {} -> forall {a}. Range -> ParseM a
bad Range
loc
TTuple {} -> forall {a}. Range -> ParseM a
bad Range
loc
TParens {} -> forall {a}. Range -> ParseM a
bad Range
loc
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm Range
rng Integer
k Integer
p
| Integer
k forall a. Eq a => a -> a -> Bool
== Integer
0 = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Integer
p)
| Integer
k forall a. Eq a => a -> a -> Bool
== Integer
1 = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Integer
p)
| Bool
otherwise = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
rng [FilePath
"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 forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int) = Integer -> [Int] -> ParseM (Expr PName)
mk Integer
0 (forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Integer -> a
fromInteger [Integer]
bits)
| Bool
otherwise = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
rng [FilePath
"Polynomial literal too large: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Integer
w]
where
w :: Integer
w = case [(Bool, Integer)]
terms of
[] -> Integer
0
[(Bool, Integer)]
_ -> Integer
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. Literal -> Expr n
ELit forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
res (Int -> NumInfo
PolyLit (forall a. Num a => Integer -> a
fromInteger Integer
w :: Int))
mk Integer
res (Int
n : [Int]
ns)
| forall a. Bits a => a -> Int -> Bool
testBit Integer
res Int
n = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
rng
[FilePath
"Polynomial contains multiple terms with exponent " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
n]
| Bool
otherwise = Integer -> [Int] -> ParseM (Expr PName)
mk (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 = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (LPName
f,Expr PName
e) forall a b. (a -> b) -> a -> b
$
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName = LPName
f
, bParams :: [Pattern PName]
bParams = forall a. [a] -> [a]
reverse [Pattern PName]
ps
, bDef :: Located (BindDef PName)
bDef = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (forall a. Range -> a -> Located a
Located Range
emptyRange (forall name. Expr name -> BindDef name
DExpr Expr PName
e))
, bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = [Pragma
PragmaProperty]
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Bool
False
, bFixity :: Maybe Fixity
bFixity = forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = 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 =
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName = LPName
f
, bParams :: [Pattern PName]
bParams = forall a. [a] -> [a]
reverse [Pattern PName]
ps
, bDef :: Located (BindDef PName)
bDef = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (forall a. Range -> a -> Located a
Located Range
emptyRange (forall name. Expr name -> BindDef name
DExpr Expr PName
rhs))
, bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Bool
False
, bFixity :: Maybe Fixity
bFixity = forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = 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 (forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
e
mkPropGuardsDecl ::
LPName ->
([Pattern PName], [Pattern PName]) ->
[PropGuardCase PName] ->
ParseM (Decl PName)
mkPropGuardsDecl :: LPName
-> ([Pattern PName], [Pattern PName])
-> [PropGuardCase PName]
-> ParseM (Decl PName)
mkPropGuardsDecl LPName
f ([Pattern PName]
ps, [Pattern PName]
ixs) [PropGuardCase PName]
guards =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ixs) forall a b. (a -> b) -> a -> b
$
forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange LPName
f)
[FilePath
"Indexed sequence definitions may not use constraint guards"]
let gs :: [PropGuardCase PName]
gs = forall a. [a] -> [a]
reverse [PropGuardCase PName]
guards
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName = LPName
f
, bParams :: [Pattern PName]
bParams = forall a. [a] -> [a]
reverse [Pattern PName]
ps
, bDef :: Located (BindDef PName)
bDef = forall a. Range -> a -> Located a
Located (forall a. Located a -> Range
srcRange LPName
f) (forall name. [PropGuardCase name] -> BindDef name
DPropGuards [PropGuardCase PName]
gs)
, bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Bool
False
, bFixity :: Maybe Fixity
bFixity = forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
}
mkConstantPropGuardsDecl ::
LPName -> [PropGuardCase PName] -> ParseM (Decl PName)
mkConstantPropGuardsDecl :: LPName -> [PropGuardCase PName] -> ParseM (Decl PName)
mkConstantPropGuardsDecl LPName
f [PropGuardCase PName]
guards =
LPName
-> ([Pattern PName], [Pattern PName])
-> [PropGuardCase PName]
-> ParseM (Decl PName)
mkPropGuardsDecl LPName
f ([],[]) [PropGuardCase PName]
guards
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
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ps = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate (forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body
| Bool
otherwise = forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun forall n. FunDesc n
emptyFunDesc (forall a. [a] -> [a]
reverse [Pattern PName]
ps) ([Pattern PName] -> Expr PName -> Expr PName
mkGenerate (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 =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pattern PName
pat Expr PName
e -> forall n. Expr n -> Expr n
EGenerate (forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 = 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 = BindDef PName
-> Maybe (Located Text)
-> LPName
-> Schema PName
-> [TopDecl PName]
mkNoImplDecl forall name. BindDef name
DPrim
mkForeignDecl ::
Maybe (Located Text) -> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl :: Maybe (Located Text)
-> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl Maybe (Located Text)
mbDoc LPName
nm Schema PName
ty =
do let txt :: FilePath
txt = Ident -> FilePath
unpackIdent (PName -> Ident
getIdent (forall a. Located a -> a
thing LPName
nm))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isOk FilePath
txt)
(forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange LPName
nm)
[ FilePath
"`" forall a. [a] -> [a] -> [a]
++ FilePath
txt forall a. [a] -> [a] -> [a]
++ FilePath
"` is not a valid foreign name."
, FilePath
"The name should contain only alpha-numeric characters or '_'."
])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BindDef PName
-> Maybe (Located Text)
-> LPName
-> Schema PName
-> [TopDecl PName]
mkNoImplDecl forall name. BindDef name
DForeign Maybe (Located Text)
mbDoc LPName
nm Schema PName
ty)
where
isOk :: Char -> Bool
isOk Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c
mkNoImplDecl :: BindDef PName
-> Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkNoImplDecl :: BindDef PName
-> Maybe (Located Text)
-> LPName
-> Schema PName
-> [TopDecl PName]
mkNoImplDecl BindDef PName
def Maybe (Located Text)
mbDoc LPName
ln Schema PName
sig =
[ Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
Public
forall a b. (a -> b) -> a -> b
$ forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName = LPName
ln
, bParams :: [Pattern PName]
bParams = []
, bDef :: Located (BindDef PName)
bDef = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Schema PName
sig (forall a. Range -> a -> Located a
Located Range
emptyRange BindDef PName
def)
, bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Ident -> Bool
isInfixIdent (PName -> Ident
getIdent (forall a. Located a -> a
thing LPName
ln))
, bFixity :: Maybe Fixity
bFixity = forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
}
, Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl forall a. Maybe a
Nothing ExportType
Public
forall a b. (a -> b) -> a -> b
$ 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 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {n}. TParam n -> ParseM (n, (TParam n, Kind))
tpK [TParam PName]
as
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {a}. Eq a => [a] -> Bool
distinct (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PName, (TParam PName, Kind))]
vs)) forall a b. (a -> b) -> a -> b
$
forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
schema_rng [FilePath
"Repeated parameters."]
let kindMap :: Map PName (TParam PName, Kind)
kindMap = 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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. Located a -> a
thing LPName
v) Map PName (TParam PName, Kind)
kindMap of
Just (TParam PName
k,Kind
tp) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam PName
k,Kind
tp)
Maybe (TParam PName, Kind)
Nothing ->
forall a. Range -> [FilePath] -> ParseM a
errorMessage
(forall a. Located a -> Range
srcRange LPName
v)
[FilePath
"Undefined parameter: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp (forall a. Located a -> a
thing LPName
v))]
([TParam PName]
as',[Kind]
ins) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PName, (TParam PName, Kind))]
vs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPName]
xs) forall a b. (a -> b) -> a -> b
$
forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
schema_rng [FilePath
"All parameters should appear in the type."]
let ki :: Located Kind
ki = Located Kind
finK { thing :: Kind
thing = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Kind -> Kind -> Kind
KFun (forall a. Located a -> a
thing Located Kind
finK) [Kind]
ins }
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel
{ tlExport :: ExportType
tlExport = ExportType
Public
, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
mbDoc
, tlValue :: PrimType PName
tlValue = 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 = forall a. Maybe a
Nothing
}
}
]
Maybe (LPName, [LPName])
Nothing -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
schema_rng [FilePath
"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 -> forall {a} {a}.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r 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 -> 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
_ -> 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}. Range -> Type a -> Maybe (Located a)
isVar Range
r) [Type a]
ts
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall {a}. Eq a => [a] -> Bool
distinct (forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
thing [Located a]
ts1))
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 [] -> forall a. a -> Maybe a
Just Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n }
Type 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 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 forall n. TParam n -> Maybe Kind
tpKind TParam n
tp of
Just Kind
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall n. TParam n -> n
tpName TParam n
tp, (TParam n
tp,Kind
k))
Maybe Kind
Nothing ->
case forall n. TParam n -> Maybe Range
tpRange TParam n
tp of
Just Range
r -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"Parameters need a kind annotation"]
Maybe Range
Nothing -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkPrimTypeDecl"
[ FilePath
"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
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
dropPrefix
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
trimFront
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
commentChar
forall a b. (a -> b) -> a -> b
$ forall a. Located a -> a
thing Located Text
ltxt
commentChar :: Char -> Bool
commentChar :: Char -> Bool
commentChar Char
x = Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
"/* \r\n\t" :: String)
prefixDroppable :: Char -> Bool
prefixDroppable Char
x = Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
"* \r\n\t" :: String)
whitespaceChar :: Char -> Bool
whitespaceChar :: Char -> Bool
whitespaceChar Char
x = Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
" \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 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
&&
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Text -> Bool
commonPrefix Char
c) [Text]
ls -> [Text] -> [Text]
dropPrefix (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 forall a. Eq a => a -> a -> Bool
== Char
c'
Maybe (Char, Text)
Nothing -> Char -> Bool
whitespaceChar Char
c
distrLoc :: Located [a] -> [Located a]
distrLoc :: forall a. Located [a] -> [Located a]
distrLoc Located [a]
x = [ Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
a } | a
a <- forall a. Located a -> a
thing Located [a]
x ]
where r :: Range
r = forall a. Located a -> Range
srcRange Located [a]
x
mkPropGuards :: Type PName -> ParseM [Located (Prop PName)]
mkPropGuards :: Type PName -> ParseM [Located (Prop PName)]
mkPropGuards Type PName
ty =
do Located [Prop PName]
lp <- Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located [Prop PName]
lp { thing :: Prop PName
thing = Prop PName
p } | Prop PName
p <- forall a. Located a -> a
thing Located [Prop PName]
lp ]
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 -> forall a. Range -> a -> Located a
Located Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall {n}. Range -> Type n -> ParseM [Prop n]
props Range
r Type PName
t
Type PName
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"Parser" [ FilePath
"Invalid type given to mkProp"
, FilePath
"expected a location"
, forall a. Show a => a -> FilePath
show Type PName
ty ]
where
props :: Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t =
case Type n
t of
TInfix{} -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall n. Type n -> Prop n
CType Type n
t]
TUser{} -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall n. Type n -> Prop n
CType Type n
t]
TTuple [Type n]
ts -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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' Maybe Kind
mb -> case Maybe Kind
mb of
Maybe Kind
Nothing -> Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t'
Just Kind
_ -> forall a. ParseM a
err
TLocated Type n
t' Range
r' -> Range -> Type n -> ParseM [Prop n]
props Range
r' Type n
t'
TFun{} -> forall a. ParseM a
err
TSeq{} -> forall a. ParseM a
err
TBit{} -> forall a. ParseM a
err
TNum{} -> forall a. ParseM a
err
TChar{} -> forall a. ParseM a
err
Type n
TWild -> forall a. ParseM a
err
TRecord{} -> forall a. ParseM a
err
TTyApp{} -> forall a. ParseM a
err
where
err :: ParseM a
err = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"Invalid constraint"]
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule Located ModName
nm [TopDecl PName]
ds = Module { mName :: Located ModName
mName = Located ModName
nm
, mDef :: ModuleDefinition PName
mDef = forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
ds
}
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested Module PName
m =
case ModName -> [FilePath]
modNameChunks (forall a. Located a -> a
thing Located ModName
nm) of
[FilePath
c] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. ModuleG name name -> NestedModule name
NestedModule Module PName
m { mName :: LPName
mName = Located ModName
nm { thing :: PName
thing = Ident -> PName
mkUnqual (FilePath -> Ident
packIdent FilePath
c)}})
[FilePath]
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r
[FilePath
"Nested modules names should be a simple identifier."]
where
nm :: Located ModName
nm = forall mname name. ModuleG mname name -> Located mname
mName Module PName
m
r :: Range
r = forall a. Located a -> Range
srcRange Located ModName
nm
mkSigDecl :: Maybe (Located Text) -> (Located PName,Signature PName) -> TopDecl PName
mkSigDecl :: Maybe (Located Text) -> (LPName, Signature PName) -> TopDecl PName
mkSigDecl Maybe (Located Text)
doc (LPName
nm,Signature PName
sig) =
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule
TopLevel { tlExport :: ExportType
tlExport = ExportType
Public
, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
doc
, tlValue :: NestedModule PName
tlValue = forall name. ModuleG name name -> NestedModule name
NestedModule
Module { mName :: LPName
mName = LPName
nm
, mDef :: ModuleDefinition PName
mDef = forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
}
}
mkInterfaceConstraint ::
Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint :: Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint Maybe (Located Text)
mbDoc Type PName
ty =
do Located [Prop PName]
ps <- Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty
forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall name. Maybe Text -> Located [Prop name] -> TopDecl name
DInterfaceConstraint (forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc) Located [Prop PName]
ps]
mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls [ParamDecl PName]
ds = forall name. Range -> Signature name -> TopDecl name
DParamDecl Range
loc ([Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> Signature PName
mkInterface' [] [ParamDecl PName]
ds)
where loc :: Range
loc = [Range] -> Range
rCombs (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall t. HasLoc t => t -> Maybe Range
getLoc [ParamDecl PName]
ds)
onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {mname}. Located (ImportG mname) -> ParseM ()
check
where
check :: Located (ImportG mname) -> ParseM ()
check Located (ImportG mname)
i =
case forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (forall a. Located a -> a
thing Located (ImportG mname)
i) of
Maybe (ModuleInstanceArgs PName)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just ModuleInstanceArgs PName
_ ->
forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange Located (ImportG mname)
i)
[ FilePath
"Functor instantiations are not supported in this context."
, FilePath
"The imported entity needs to be just the name of a module."
, FilePath
"A workaround would be to do the instantion in the outer context."
]
mkInterface' :: [Located (ImportG (ImpName PName))] ->
[ParamDecl PName] -> Signature PName
mkInterface' :: [Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> Signature PName
mkInterface' [Located (ImportG (ImpName PName))]
is =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {name}. Signature name -> ParamDecl name -> Signature name
add
Signature { sigImports :: [Located (ImportG (ImpName PName))]
sigImports = [Located (ImportG (ImpName PName))]
is
, sigTypeParams :: [ParameterType PName]
sigTypeParams = []
, sigDecls :: [SigDecl PName]
sigDecls = []
, sigConstraints :: [Located (Prop PName)]
sigConstraints = []
, sigFunParams :: [ParameterFun PName]
sigFunParams = []
}
where
add :: Signature name -> ParamDecl name -> Signature name
add Signature name
s ParamDecl name
d =
case ParamDecl name
d of
DParameterType ParameterType name
pt -> Signature name
s { sigTypeParams :: [ParameterType name]
sigTypeParams = ParameterType name
pt forall a. a -> [a] -> [a]
: forall name. Signature name -> [ParameterType name]
sigTypeParams Signature name
s }
DParameterConstraint [Located (Prop name)]
ps -> Signature name
s { sigConstraints :: [Located (Prop name)]
sigConstraints = [Located (Prop name)]
ps forall a. [a] -> [a] -> [a]
++ forall name. Signature name -> [Located (Prop name)]
sigConstraints Signature name
s }
DParameterDecl SigDecl name
pd -> Signature name
s { sigDecls :: [SigDecl name]
sigDecls = SigDecl name
pd forall a. a -> [a] -> [a]
: forall name. Signature name -> [SigDecl name]
sigDecls Signature name
s }
DParameterFun ParameterFun name
pf -> Signature name
s { sigFunParams :: [ParameterFun name]
sigFunParams = ParameterFun name
pf forall a. a -> [a] -> [a]
: forall name. Signature name -> [ParameterFun name]
sigFunParams Signature name
s }
mkInterface :: [Located (ImportG (ImpName PName))] ->
[ParamDecl PName] -> ParseM (Signature PName)
mkInterface :: [Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> ParseM (Signature PName)
mkInterface [Located (ImportG (ImpName PName))]
is [ParamDecl PName]
ps =
do [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports [Located (ImportG (ImpName PName))]
is
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> Signature PName
mkInterface' [Located (ImportG (ImpName PName))]
is [ParamDecl PName]
ps)
mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn Maybe Text
mbDoc Decl PName
d =
case Decl PName
d of
DLocated Decl PName
d1 Range
_ -> Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn Maybe Text
mbDoc Decl PName
d1
DType TySyn PName
ts -> forall name. SigDecl name -> ParamDecl name
DParameterDecl (forall name. TySyn name -> Maybe Text -> SigDecl name
SigTySyn TySyn PName
ts Maybe Text
mbDoc)
DProp PropSyn PName
ps -> forall name. SigDecl name -> ParamDecl name
DParameterDecl (forall name. PropSyn name -> Maybe Text -> SigDecl name
SigPropSyn PropSyn PName
ps Maybe Text
mbDoc)
Decl PName
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkIfacePropSyn" [ FilePath
"Unexpected declaration", forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp Decl PName
d) ]
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule = Module PName -> ParseM [Module PName]
mkTopMods
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModName -> [TopDecl PName] -> Module PName
mkModule Located { srcRange :: Range
srcRange = Range
emptyRange
, thing :: ModName
thing = [Text] -> ModName
mkModName [FilePath -> Text
T.pack FilePath
"Main"]
}
mkModuleInstanceAnon :: Located ModName ->
Located (ImpName PName) ->
[TopDecl PName] ->
Module PName
mkModuleInstanceAnon :: Located ModName
-> Located (ImpName PName) -> [TopDecl PName] -> Module PName
mkModuleInstanceAnon Located ModName
nm Located (ImpName PName)
fun [TopDecl PName]
ds =
Module { mName :: Located ModName
mName = Located ModName
nm
, mDef :: ModuleDefinition PName
mDef = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
fun (forall name. [TopDecl name] -> ModuleInstanceArgs name
DefaultInstAnonArg [TopDecl PName]
ds) forall a. Monoid a => a
mempty
}
mkModuleInstance ::
Located ModName ->
Located (ImpName PName) ->
ModuleInstanceArgs PName ->
Module PName
mkModuleInstance :: Located ModName
-> Located (ImpName PName)
-> ModuleInstanceArgs PName
-> Module PName
mkModuleInstance Located ModName
m Located (ImpName PName)
f ModuleInstanceArgs PName
as =
Module { mName :: Located ModName
mName = Located ModName
m
, mDef :: ModuleDefinition PName
mDef = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as forall name. Ord name => ModuleInstance name
emptyModuleInstance
}
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 <- forall a. Located a -> a
thing Located Selector
l ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Named { name :: Located Ident
name = Located Selector
l { thing :: Ident
thing = Ident
i }, value :: Expr PName
value = Expr PName
e }
(UpdHow, [Located Selector])
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange (forall a. [a] -> a
head [Located Selector]
ls))
[FilePath
"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 = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM [Located Selector]
go forall {a}. a
noLoc Expr PName
e0
where
noLoc :: a
noLoc = forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"selExprToSels" [FilePath
"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 (forall a. Located a -> Range
srcRange (forall a. [a] -> a
head [Located Selector]
ls)) }
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located { thing :: Selector
thing = Selector
s, srcRange :: Range
srcRange = Range
rng } forall a. a -> [a] -> [a]
: [Located Selector]
ls)
EVar (UnQual Ident
l) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing = Ident -> Maybe [Ident] -> Selector
RecordSel Ident
l forall a. Maybe a
Nothing, srcRange :: Range
srcRange = Range
loc } ]
ELit (ECNum Integer
n (DecLit {})) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel (forall a. Num a => Integer -> a
fromInteger Integer
n) 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 (forall a. Eq a => a -> a -> Bool
== Char
'.') Text
txt
, Just Int
a <- forall a. Read a => FilePath -> Maybe a
readMaybe (Text -> FilePath
T.unpack Text
as)
, Just (Char
_,Text
bs) <- Text -> Maybe (Char, Text)
T.uncons Text
bs'
, Just Int
b <- forall a. Read a => FilePath -> Maybe a
readMaybe (Text -> FilePath
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 forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
as forall a. Num a => a -> a -> a
+ Int
1 } ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel Int
b forall a. Maybe a
Nothing
, srcRange :: Range
srcRange = Range
loc { from :: Position
from = Position
midP }
}
, Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel Int
a forall a. Maybe a
Nothing
, srcRange :: Range
srcRange = Range
loc { to :: Position
to = Position
midP }
}
]
Expr PName
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [FilePath
"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 forall a. Maybe a
Nothing
Selector (RecordSelectorTok Text
t) -> Ident -> Maybe [Ident] -> Selector
RecordSel (Text -> Ident
mkIdent Text
t) forall a. Maybe a
Nothing
TokenT
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkSelector" [ FilePath
"Unexpected selector token", forall a. Show a => a -> FilePath
show Token
tok ]
mkBacktickImport ::
Range ->
Located (ImpName PName) ->
Maybe (Located ModName) ->
Maybe (Located ImportSpec) ->
ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport :: Range
-> Located (ImpName PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport Range
loc Located (ImpName PName)
impName Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec =
Range
-> Located (ImpName PName)
-> Maybe (ModuleInstanceArgs PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> Maybe (Located [Decl PName])
-> ParseM (Located (ImportG (ImpName PName)))
mkImport Range
loc Located (ImpName PName)
impName (forall a. a -> Maybe a
Just forall {name}. ModuleInstanceArgs name
inst) Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec forall a. Maybe a
Nothing
where
inst :: ModuleInstanceArgs name
inst = forall name.
Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
DefaultInstArg (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall name. ModuleInstanceArg name
AddParams) Located (ImpName PName)
impName)
mkImport ::
Range ->
Located (ImpName PName) ->
Maybe (ModuleInstanceArgs PName) ->
Maybe (Located ModName) ->
Maybe (Located ImportSpec) ->
Maybe (Located [Decl PName]) ->
ParseM (Located (ImportG (ImpName PName)))
mkImport :: Range
-> Located (ImpName PName)
-> Maybe (ModuleInstanceArgs PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> Maybe (Located [Decl PName])
-> ParseM (Located (ImportG (ImpName PName)))
mkImport Range
loc Located (ImpName PName)
impName Maybe (ModuleInstanceArgs PName)
optInst Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec Maybe (Located [Decl PName])
optImportWhere =
do Maybe (ModuleInstanceArgs PName)
i <- ParseM (Maybe (ModuleInstanceArgs PName))
getInst
let end :: Range
end = forall a. a -> Maybe a -> a
fromMaybe (forall a. Located a -> Range
srcRange Located (ImpName PName)
impName)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ forall a. Located a -> Range
srcRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located [Decl PName])
optImportWhere
, forall a. Located a -> Range
srcRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ImportSpec)
mbImportSpec
, forall a. Located a -> Range
srcRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ModName)
mbAs
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located { srcRange :: Range
srcRange = Range -> Range -> Range
rComb Range
loc Range
end
, thing :: ImportG (ImpName PName)
thing = Import
{ iModule :: ImpName PName
iModule = forall a. Located a -> a
thing Located (ImpName PName)
impName
, iAs :: Maybe ModName
iAs = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ModName)
mbAs
, iSpec :: Maybe ImportSpec
iSpec = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ImportSpec)
mbImportSpec
, iInst :: Maybe (ModuleInstanceArgs PName)
iInst = Maybe (ModuleInstanceArgs PName)
i
}
}
where
getInst :: ParseM (Maybe (ModuleInstanceArgs PName))
getInst =
case (Maybe (ModuleInstanceArgs PName)
optInst,Maybe (Located [Decl PName])
optImportWhere) of
(Just ModuleInstanceArgs PName
_, Just Located [Decl PName]
_) ->
forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [ FilePath
"Invalid instantiating import."
, FilePath
"Import should have at most one of:"
, FilePath
" * { } instantiation, or"
, FilePath
" * where instantiation"
]
(Just ModuleInstanceArgs PName
a, Maybe (Located [Decl PName])
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ModuleInstanceArgs PName
a)
(Maybe (ModuleInstanceArgs PName)
Nothing, Just Located [Decl PName]
a) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall name. [TopDecl name] -> ModuleInstanceArgs name
DefaultInstAnonArg (forall a b. (a -> b) -> [a] -> [b]
map forall {name}. Decl name -> TopDecl name
instTop (forall a. Located a -> a
thing Located [Decl PName]
a))))
where
instTop :: Decl name -> TopDecl name
instTop Decl name
d = forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel
{ tlExport :: ExportType
tlExport = ExportType
Public
, tlDoc :: Maybe (Located Text)
tlDoc = forall a. Maybe a
Nothing
, tlValue :: Decl name
tlValue = Decl name
d
}
(Maybe (ModuleInstanceArgs PName)
Nothing, Maybe (Located [Decl PName])
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
mkTopMods :: Module PName -> ParseM [Module PName]
mkTopMods :: Module PName -> ParseM [Module PName]
mkTopMods = forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod
mkTopSig :: Located ModName -> Signature PName -> [Module PName]
mkTopSig :: Located ModName -> Signature PName -> [Module PName]
mkTopSig Located ModName
nm Signature PName
sig =
[ Module { mName :: Located ModName
mName = Located ModName
nm
, mDef :: ModuleDefinition PName
mDef = forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
}
]
class MkAnon t where
mkAnon :: AnonThing -> t -> t
toImpName :: t -> ImpName PName
data AnonThing = AnonArg | AnonIfaceMod
instance MkAnon ModName where
mkAnon :: AnonThing -> ModName -> ModName
mkAnon AnonThing
what = case AnonThing
what of
AnonThing
AnonArg -> ModName -> ModName
modNameArg
AnonThing
AnonIfaceMod -> ModName -> ModName
modNameIfaceMod
toImpName :: ModName -> ImpName PName
toImpName = forall name. ModName -> ImpName name
ImpTop
instance MkAnon PName where
mkAnon :: AnonThing -> PName -> PName
mkAnon AnonThing
what = Ident -> PName
mkUnqual
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case AnonThing
what of
AnonThing
AnonArg -> Ident -> Ident
identAnonArg
AnonThing
AnonIfaceMod -> Ident -> Ident
identAnonIfaceMod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PName -> Ident
getIdent
toImpName :: PName -> ImpName PName
toImpName = forall name. name -> ImpName name
ImpNested
desugarMod :: MkAnon name => ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod :: forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod ModuleG name PName
mo =
case forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG name PName
mo of
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
_ | DefaultInstAnonArg [TopDecl PName]
lds <- ModuleInstanceArgs PName
as ->
do ([ModuleG name PName]
ms,[TopDecl PName]
lds') <- forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) [TopDecl PName]
lds
case [ModuleG name PName]
ms of
ModuleG name PName
m : [ModuleG name PName]
_ | InterfaceModule Signature PName
si <- forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG name PName
m
, Range
l : [Range]
_ <- forall a b. (a -> b) -> [a] -> [b]
map (forall a. Located a -> Range
srcRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. ParameterType name -> Located name
ptName) (forall name. Signature name -> [ParameterType name]
sigTypeParams Signature PName
si) forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (forall a. Located a -> Range
srcRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. ParameterFun name -> Located name
pfName) (forall name. Signature name -> [ParameterFun name]
sigFunParams Signature PName
si) forall a. [a] -> [a] -> [a]
++
[ forall a. Located a -> Range
srcRange (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) ] ->
forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
l
[ FilePath
"Instantiation of a parameterized module may not itself be "
forall a. [a] -> [a] -> [a]
++ FilePath
"parameterized" ]
[ModuleG name PName]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let i :: name
i = forall t. MkAnon t => AnonThing -> t -> t
mkAnon AnonThing
AnonArg (forall a. Located a -> a
thing (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo))
nm :: Located name
nm = Located { srcRange :: Range
srcRange = forall a. Located a -> Range
srcRange (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo), thing :: name
thing = name
i }
as' :: ModuleInstanceArgs PName
as' = forall name.
Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
DefaultInstArg (forall name. ImpName name -> ModuleInstanceArg name
ModuleArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MkAnon t => t -> ImpName PName
toImpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Module { mName :: Located name
mName = Located name
nm, mDef :: ModuleDefinition PName
mDef = forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
lds' }
, ModuleG name PName
mo { mDef :: ModuleDefinition PName
mDef = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as' forall a. Monoid a => a
mempty }
]
NormalModule [TopDecl PName]
ds ->
do ([ModuleG name PName]
newMs, [TopDecl PName]
newDs) <- forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) [TopDecl PName]
ds
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleG name PName]
newMs forall a. [a] -> [a] -> [a]
++ [ ModuleG name PName
mo { mDef :: ModuleDefinition PName
mDef = forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
newDs } ])
ModuleDefinition PName
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [ModuleG name PName
mo]
desugarTopDs ::
MkAnon name =>
Located name ->
[TopDecl PName] ->
ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs :: forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs Located name
ownerName = Signature PName
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
go forall {name}. Signature name
emptySig
where
isEmpty :: Signature name -> Bool
isEmpty Signature name
s =
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Signature name -> [ParameterType name]
sigTypeParams Signature name
s) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Signature name -> [Located (Prop name)]
sigConstraints Signature name
s) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Signature name -> [ParameterFun name]
sigFunParams Signature name
s)
emptySig :: Signature name
emptySig = Signature
{ sigImports :: [Located (ImportG (ImpName name))]
sigImports = []
, sigTypeParams :: [ParameterType name]
sigTypeParams = []
, sigDecls :: [SigDecl name]
sigDecls = []
, sigConstraints :: [Located (Prop name)]
sigConstraints = []
, sigFunParams :: [ParameterFun name]
sigFunParams = []
}
jnSig :: Signature name -> Signature name -> Signature name
jnSig Signature name
s1 Signature name
s2 = Signature { sigImports :: [Located (ImportG (ImpName name))]
sigImports = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [Located (ImportG (ImpName name))]
sigImports
, sigTypeParams :: [ParameterType name]
sigTypeParams = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [ParameterType name]
sigTypeParams
, sigDecls :: [SigDecl name]
sigDecls = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [SigDecl name]
sigDecls
, sigConstraints :: [Located (Prop name)]
sigConstraints = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [Located (Prop name)]
sigConstraints
, sigFunParams :: [ParameterFun name]
sigFunParams = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [ParameterFun name]
sigFunParams
}
where
j :: (Signature name -> [a]) -> [a]
j Signature name -> [a]
f = Signature name -> [a]
f Signature name
s1 forall a. [a] -> [a] -> [a]
++ Signature name -> [a]
f Signature name
s2
addI :: Located (ImportG (ImpName name))
-> Signature name -> Signature name
addI Located (ImportG (ImpName name))
i Signature name
s = Signature name
s { sigImports :: [Located (ImportG (ImpName name))]
sigImports = Located (ImportG (ImpName name))
i forall a. a -> [a] -> [a]
: forall name. Signature name -> [Located (ImportG (ImpName name))]
sigImports Signature name
s }
go :: Signature PName
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
go Signature PName
sig [TopDecl PName]
ds =
case [TopDecl PName]
ds of
[]
| forall {name}. Signature name -> Bool
isEmpty Signature PName
sig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([],[])
| Bool
otherwise ->
do let nm :: Located name
nm = forall t. MkAnon t => AnonThing -> t -> t
mkAnon AnonThing
AnonIfaceMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
ownerName
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [ Module { mName :: Located name
mName = Located name
nm
, mDef :: ModuleDefinition PName
mDef = forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
}
]
, [ forall name. ModParam name -> TopDecl name
DModParam
ModParam
{ mpSignature :: Located (ImpName PName)
mpSignature = forall t. MkAnon t => t -> ImpName PName
toImpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm
, mpAs :: Maybe ModName
mpAs = forall a. Maybe a
Nothing
, mpName :: Ident
mpName = Located (ImpName PName) -> Maybe (Located ModName) -> Ident
mkModParamName (forall t. MkAnon t => t -> ImpName PName
toImpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm)
forall a. Maybe a
Nothing
, mpDoc :: Maybe (Located Text)
mpDoc = forall a. Maybe a
Nothing
, mpRenaming :: ModuleInstance PName
mpRenaming = forall a. Monoid a => a
mempty
}
]
)
TopDecl PName
d : [TopDecl PName]
more ->
let cont :: [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName]
emit Signature PName
sig' =
do ([ModuleG name PName]
ms,[TopDecl PName]
ds') <- Signature PName
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
go Signature PName
sig' [TopDecl PName]
more
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleG name PName]
ms, [TopDecl PName]
emit forall a. [a] -> [a] -> [a]
++ [TopDecl PName]
ds')
in
case TopDecl PName
d of
DImport Located (ImportG (ImpName PName))
i | ImpTop ModName
_ <- forall mname. ImportG mname -> mname
iModule (forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i)
, Maybe (ModuleInstanceArgs PName)
Nothing <- forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i) ->
[TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName
d] (forall {name}.
Located (ImportG (ImpName name))
-> Signature name -> Signature name
addI Located (ImportG (ImpName PName))
i Signature PName
sig)
DImport Located (ImportG (ImpName PName))
i | Just ModuleInstanceArgs PName
inst <- forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i) ->
do [TopDecl PName]
newDs <- Located (ImportG (ImpName PName))
-> ModuleInstanceArgs PName -> ParseM [TopDecl PName]
desugarInstImport Located (ImportG (ImpName PName))
i ModuleInstanceArgs PName
inst
[TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName]
newDs Signature PName
sig
DParamDecl Range
_ Signature PName
ds' -> [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [] (forall {name}. Signature name -> Signature name -> Signature name
jnSig Signature PName
ds' Signature PName
sig)
DModule TopLevel (NestedModule PName)
tl | NestedModule ModuleG PName PName
mo <- forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
tl ->
do [ModuleG PName PName]
ms <- forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod ModuleG PName PName
mo
[TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [ forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
tl { tlValue :: NestedModule PName
tlValue = forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG PName PName
m } | ModuleG PName PName
m <- [ModuleG PName PName]
ms ] Signature PName
sig
TopDecl PName
_ -> [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName
d] Signature PName
sig
desugarInstImport ::
Located (ImportG (ImpName PName)) ->
ModuleInstanceArgs PName ->
ParseM [TopDecl PName]
desugarInstImport :: Located (ImportG (ImpName PName))
-> ModuleInstanceArgs PName -> ParseM [TopDecl PName]
desugarInstImport Located (ImportG (ImpName PName))
i ModuleInstanceArgs PName
inst =
do [ModuleG PName PName]
ms <- forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod
Module { mName :: LPName
mName = Located (ImportG (ImpName PName))
i { thing :: PName
thing = PName
iname }
, mDef :: ModuleDefinition PName
mDef = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance
(forall mname. ImportG mname -> mname
iModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (ImportG (ImpName PName))
i) ModuleInstanceArgs PName
inst forall name. Ord name => ModuleInstance name
emptyModuleInstance
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. Located (ImportG (ImpName name)) -> TopDecl name
DImport (forall {mname}. ImportG mname -> ImportG (ImpName PName)
newImp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (ImportG (ImpName PName))
i) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {name}. ModuleG name name -> TopDecl name
modTop [ModuleG PName PName]
ms)
where
imp :: ImportG (ImpName PName)
imp = forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i
iname :: PName
iname = Ident -> PName
mkUnqual
forall a b. (a -> b) -> a -> b
$ Text -> Ident
mkIdent
forall a b. (a -> b) -> a -> b
$ Text
"import of " forall a. Semigroup a => a -> a -> a
<> Text
nm forall a. Semigroup a => a -> a -> a
<> Text
" at " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located (ImportG (ImpName PName))
i)))
where
nm :: Text
nm = case forall mname. ImportG mname -> mname
iModule ImportG (ImpName PName)
imp of
ImpTop ModName
f -> ModName -> Text
modNameToText ModName
f
ImpNested PName
n -> Text
"submodule " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp PName
n))
newImp :: ImportG mname -> ImportG (ImpName PName)
newImp ImportG mname
d = ImportG mname
d { iModule :: ImpName PName
iModule = forall name. name -> ImpName name
ImpNested PName
iname
, iInst :: Maybe (ModuleInstanceArgs PName)
iInst = forall a. Maybe a
Nothing
}
modTop :: ModuleG name name -> TopDecl name
modTop ModuleG name name
m = forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel
{ tlExport :: ExportType
tlExport = ExportType
Private
, tlDoc :: Maybe (Located Text)
tlDoc = forall a. Maybe a
Nothing
, tlValue :: NestedModule name
tlValue = forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG name name
m
}