-- |
-- Module      :  Cryptol.Parser.ParserUtils
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE Safe #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# 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, isUpperIdent
                          )
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 -> [Char] -> Either ParseError a
parseString Config
cfg ParseM a
p [Char]
cs = Config -> ParseM a -> Text -> Either ParseError a
forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p ([Char] -> Text
T.pack [Char]
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 ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
p Config
cfg Position
eofPos S { sPrevTok :: Maybe (Located Token)
sPrevTok = Maybe (Located Token)
forall a. Maybe a
Nothing
                                            , sTokens :: [Located Token]
sTokens = [Located Token]
toks
                                            , sNextTyParamNum :: Int
sNextTyParamNum = Int
0
                                            } of
                      Left ParseError
err    -> ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
err
                      Right (a
a,S
_) -> a -> Either ParseError a
forall a b. b -> Either a b
Right a
a
  where ([Located Token]
toks,Position
eofPos) = Config -> Text -> ([Located Token], Position)
lexer Config
cfg Text
cs


{- The parser is parameterized by the pozition of the final token. -}
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 = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
p S
s ->
  case S -> [Located Token]
sTokens S
s of
    Located Token
t : [Located Token]
_ | Err TokenErr
e <- Token -> TokenT
tokenType Token
it ->
      ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (ParseError -> Either ParseError (a, S))
-> ParseError -> Either ParseError (a, S)
forall a b. (a -> b) -> a -> b
$ Range -> [[Char]] -> ParseError
HappyErrorMsg (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t) ([[Char]] -> ParseError) -> [[Char]] -> ParseError
forall a b. (a -> b) -> a -> b
$
        [case TokenErr
e of
           TokenErr
UnterminatedComment -> [Char]
"unterminated comment"
           TokenErr
UnterminatedString  -> [Char]
"unterminated string"
           TokenErr
UnterminatedChar    -> [Char]
"unterminated character"
           TokenErr
InvalidString       -> [Char]
"invalid string literal: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Text -> [Char]
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
InvalidChar         -> [Char]
"invalid character literal: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Text -> [Char]
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
LexicalError        -> [Char]
"unrecognized character: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Text -> [Char]
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
MalformedLiteral    -> [Char]
"malformed literal: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Text -> [Char]
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
MalformedSelector   -> [Char]
"malformed selector: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    Text -> [Char]
T.unpack (Token -> Text
tokenText Token
it)
           InvalidIndentation TokenT
c -> [Char]
"invalid indentation, unmatched " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
              case TokenT
c of
                Sym TokenSym
CurlyR    -> [Char]
"{ ... } "
                Sym TokenSym
ParenR    -> [Char]
"( ... )"
                Sym TokenSym
BracketR  -> [Char]
"[ ... ]"
                TokenT
_             -> TokenT -> [Char]
forall a. Show a => a -> [Char]
show TokenT
c -- basically panic
        ]
      where it :: Token
it = Located Token -> Token
forall a. Located a -> a
thing Located Token
t

    Located Token
t : [Located Token]
more -> ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (Located Token -> ParseM a
k Located Token
t) Config
cfg Position
p S
s { sPrevTok = Just t, sTokens = more }
    [] -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left ([Char] -> Position -> ParseError
HappyOutOfTokens (Config -> [Char]
cfgSource Config
cfg) Position
p)

data ParseError = HappyError FilePath         {- Name of source file -}
                             (Located Token)  {- Offending token -}
                | HappyErrorMsg Range [String]
                | HappyUnexpected FilePath (Maybe (Located Token)) String
                | HappyOutOfTokens FilePath Position
                  deriving (Int -> ParseError -> [Char] -> [Char]
[ParseError] -> [Char] -> [Char]
ParseError -> [Char]
(Int -> ParseError -> [Char] -> [Char])
-> (ParseError -> [Char])
-> ([ParseError] -> [Char] -> [Char])
-> Show ParseError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ParseError -> [Char] -> [Char]
showsPrec :: Int -> ParseError -> [Char] -> [Char]
$cshow :: ParseError -> [Char]
show :: ParseError -> [Char]
$cshowList :: [ParseError] -> [Char] -> [Char]
showList :: [ParseError] -> [Char] -> [Char]
Show, (forall x. ParseError -> Rep ParseError x)
-> (forall x. Rep ParseError x -> ParseError) -> Generic ParseError
forall x. Rep ParseError x -> ParseError
forall x. ParseError -> Rep ParseError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParseError -> Rep ParseError x
from :: forall x. ParseError -> Rep ParseError x
$cto :: forall x. Rep ParseError x -> ParseError
to :: forall x. Rep ParseError x -> ParseError
Generic, ParseError -> ()
(ParseError -> ()) -> NFData ParseError
forall a. (a -> ()) -> NFData a
$crnf :: ParseError -> ()
rnf :: ParseError -> ()
NFData)

data S = S { S -> Maybe (Located Token)
sPrevTok :: Maybe (Located Token)
           , S -> [Located Token]
sTokens :: [Located Token]
           , S -> Int
sNextTyParamNum :: !Int
             -- ^ Keep track of the type parameters as they appear in the input
           }

ppError :: ParseError -> Doc

ppError :: ParseError -> Doc
ppError (HappyError [Char]
path Located Token
ltok)
  | Err TokenErr
_ <- Token -> TokenT
tokenType Token
tok =
    [Char] -> Doc
text [Char]
"Parse error at" Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
<+>
    Token -> Doc
forall a. PP a => a -> Doc
pp Token
tok

  | White TokenW
DocStr <- Token -> TokenT
tokenType Token
tok =
    Doc
"Unexpected documentation (/**) comment at" Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
indent Int
2
      Doc
"Documentation comments need to be followed by something to document."

  | Bool
otherwise =
    [Char] -> Doc
text [Char]
"Parse error at" Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
indent Int
2 ([Char] -> Doc
text [Char]
"unexpected:" Doc -> Doc -> Doc
<+> Token -> Doc
forall a. PP a => a -> Doc
pp Token
tok)
  where
  pos :: Position
pos = Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
ltok)
  tok :: Token
tok = Located Token -> Token
forall a. Located a -> a
thing Located Token
ltok

ppError (HappyOutOfTokens [Char]
path Position
pos) =
  [Char] -> Doc
text [Char]
"Unexpected end of file at:" Doc -> Doc -> Doc
<+>
    [Char] -> Doc
text [Char]
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos

ppError (HappyErrorMsg Range
p [[Char]]
xs)  = [Char] -> Doc
text [Char]
"Parse error at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
vcat (([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text [[Char]]
xs))

ppError (HappyUnexpected [Char]
path Maybe (Located Token)
ltok [Char]
e) =
  Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
   [ [Char] -> Doc
text [Char]
"Parse error at" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma ]
   [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
unexp
   [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
"expected:" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
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
<+> [Char] -> Doc
text (Text -> [Char]
T.unpack (Token -> Text
tokenText (Located Token -> Token
forall a. Located a -> a
thing Located Token
t)))]
                 , Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t)
                 )

instance Functor ParseM where
  fmap :: forall a b. (a -> b) -> ParseM a -> ParseM b
fmap = (a -> b) -> ParseM a -> ParseM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative ParseM where
  pure :: forall a. a -> ParseM a
pure a
a = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
_ Position
_ S
s -> (a, S) -> Either ParseError (a, S)
forall a b. b -> Either a b
Right (a
a,S
s))
  <*> :: forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
(<*>) = ParseM (a -> b) -> ParseM a -> ParseM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad ParseM where
  return :: forall a. a -> ParseM a
return    = a -> ParseM a
forall a. a -> ParseM a
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   = (Config -> Position -> S -> Either ParseError (b, S)) -> ParseM b
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
cfg Position
p S
s1 -> case ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
m Config
cfg Position
p S
s1 of
                            Left ParseError
e       -> ParseError -> Either ParseError (b, S)
forall a b. a -> Either a b
Left ParseError
e
                            Right (a
a,S
s2) -> ParseM b -> Config -> Position -> S -> Either ParseError (b, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (a -> ParseM b
k a
a) Config
cfg Position
p S
s2)

instance Fail.MonadFail ParseM where
  fail :: forall a. [Char] -> ParseM a
fail [Char]
s    = [Char] -> [[Char]] -> ParseM a
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] fail" [[Char]
s]

happyError :: ParseM a
happyError :: forall a. ParseM a
happyError = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
  case S -> Maybe (Located Token)
sPrevTok S
s of
    Just Located Token
t  -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left ([Char] -> Located Token -> ParseError
HappyError (Config -> [Char]
cfgSource Config
cfg) Located Token
t)
    Maybe (Located Token)
Nothing ->
      ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [[Char]] -> ParseError
HappyErrorMsg Range
emptyRange [[Char]
"Parse error at the beginning of the file"])

errorMessage :: Range -> [String] -> ParseM a
errorMessage :: forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]]
xs = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [[Char]] -> ParseError
HappyErrorMsg Range
r [[Char]]
xs)

customError :: String -> Located Token -> ParseM a
customError :: forall a. [Char] -> Located Token -> ParseM a
customError [Char]
x Located Token
t = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [[Char]] -> ParseError
HappyErrorMsg (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t) [[Char]
x])

expected :: String -> ParseM a
expected :: forall a. [Char] -> ParseM a
expected [Char]
x = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
                    ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left ([Char] -> Maybe (Located Token) -> [Char] -> ParseError
HappyUnexpected (Config -> [Char]
cfgSource Config
cfg) (S -> Maybe (Located Token)
sPrevTok S
s) [Char]
x)









mkModName :: [Text] -> ModName
mkModName :: [Text] -> ModName
mkModName = [Text] -> ModName
packModName

-- | This is how we derive the name of a module parameter from the
-- @import source@ declaration.
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 Located (ImpName PName) -> ImpName PName
forall a. Located a -> a
thing Located (ImpName PName)
lsig of
        ImpTop ModName
t
          | ModName -> Bool
modNameIsNormal ModName
t -> [Char] -> Ident
packIdent ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last (ModName -> [[Char]]
modNameChunks ModName
t))
          | Bool
otherwise         -> Ident -> Ident
identAnonIfaceMod
                               (Ident -> Ident) -> Ident -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> Ident
packIdent
                               ([Char] -> Ident) -> [Char] -> Ident
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last
                               ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ModName -> [[Char]]
modNameChunks
                               (ModName -> [[Char]]) -> ModName -> [[Char]]
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 {} -> [Char] -> [[Char]] -> Ident
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"mkModParamName" [[Char]
"Unexpected NewName",Located (ImpName PName) -> [Char]
forall a. Show a => a -> [Char]
show Located (ImpName PName)
lsig]
    Just Located ModName
m -> [Char] -> Ident
packIdent ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last (ModName -> [[Char]]
modNameChunks (Located ModName -> ModName
forall a. Located a -> a
thing Located ModName
m)))

-- Note that type variables are not resolved at this point: they are tcons.
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema [TParam PName]
xs [Prop PName]
ps Type PName
t = [TParam PName]
-> [Prop PName] -> Type PName -> Maybe Range -> Schema PName
forall n.
[TParam n] -> [Prop n] -> Type n -> Maybe Range -> Schema n
Forall [TParam PName]
xs [Prop PName]
ps Type PName
t Maybe Range
forall a. Maybe a
Nothing

getName :: Located Token -> PName
getName :: Located Token -> PName
getName Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
              Token (Ident [] Text
x) Text
_ -> Ident -> PName
mkUnqual (Text -> Ident
mkIdent Text
x)
              Token
_ -> [Char] -> [[Char]] -> PName
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] getName" [[Char]
"not an Ident:", Located Token -> [Char]
forall a. Show a => a -> [Char]
show Located Token
l]

getNum :: Located Token -> Integer
getNum :: Located Token -> Integer
getNum Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
             Token (Num Integer
x Int
_ Int
_) Text
_ -> Integer
x
             Token (ChrLit Char
x) Text
_  -> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x)
             Token
_ -> [Char] -> [[Char]] -> Integer
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] getNum" [[Char]
"not a number:", Located Token -> [Char]
forall a. Show a => a -> [Char]
show Located Token
l]

getChr :: Located Token -> Char
getChr :: Located Token -> Char
getChr Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
             Token (ChrLit Char
x) Text
_  -> Char
x
             Token
_ -> [Char] -> [[Char]] -> Char
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] getChr" [[Char]
"not a char:", Located Token -> [Char]
forall a. Show a => a -> [Char]
show Located Token
l]

getStr :: Located Token -> String
getStr :: Located Token -> [Char]
getStr Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
             Token (StrLit [Char]
x) Text
_ -> [Char]
x
             Token
_ -> [Char] -> [[Char]] -> [Char]
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] getStr" [[Char]
"not a string:", Located Token -> [Char]
forall a. Show a => a -> [Char]
show Located Token
l]

numLit :: Token -> Expr PName
numLit :: Token -> Expr PName
numLit Token { tokenText :: Token -> Text
tokenText = Text
txt, tokenType :: Token -> TokenT
tokenType = Num Integer
x Int
base Int
digs }
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2   = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
BinLit Text
txt Int
digs)
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8   = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
OctLit Text
txt Int
digs)
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10  = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> NumInfo
DecLit Text
txt)
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16  = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
HexLit Text
txt Int
digs)

numLit Token
x = [Char] -> [[Char]] -> Expr PName
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] numLit" [[Char]
"invalid numeric literal", Token -> [Char]
forall a. Show a => a -> [Char]
show Token
x]

fracLit :: Token -> Expr PName
fracLit :: Token -> Expr PName
fracLit Token
tok =
  case Token -> TokenT
tokenType Token
tok of
    Frac Rational
x Int
base
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2   -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
BinFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8   -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
OctFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10  -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
DecFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16  -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
HexFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
    TokenT
_ -> [Char] -> [[Char]] -> Expr PName
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"[Parser] fracLit" [ [Char]
"Invalid fraction", Token -> [Char]
forall a. Show a => a -> [Char]
show Token
tok ]


intVal :: Located Token -> ParseM Integer
intVal :: Located Token -> ParseM Integer
intVal Located Token
tok =
  case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
tok) of
    Num Integer
x Int
_ Int
_ -> Integer -> ParseM Integer
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
    TokenT
_         -> Range -> [[Char]] -> ParseM Integer
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) [[Char]
"Expected an integer"]

mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity Assoc
assoc Located Token
tok [LPName]
qns =
  do Integer
l <- Located Token -> ParseM Integer
intVal Located Token
tok
     Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 Bool -> Bool -> Bool
&& Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
100)
          (Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) [[Char]
"Fixity levels must be between 1 and 100"])
     Decl PName -> ParseM (Decl PName)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> [LPName] -> Decl PName
forall name. Fixity -> [Located name] -> Decl name
DFixity (Assoc -> Int -> Fixity
Fixity Assoc
assoc (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
l)) [LPName]
qns)

fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit :: Located Token -> ParseM (Located [Char])
fromStrLit Located Token
loc = case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
loc) of
  StrLit [Char]
str -> Located [Char] -> ParseM (Located [Char])
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return Located Token
loc { thing = str }
  TokenT
_          -> Range -> [[Char]] -> ParseM (Located [Char])
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
loc) [[Char]
"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 {}   -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"Record types"
    TTyApp {}    -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"Explicit type application"
    TTuple {}    -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"Tuple types"
    TFun {}      -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"Function types"
    TSeq {}      -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"Sequence types"
    Type PName
TBit         -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"Type bit"
    TNum {}      -> ParseM (Type PName)
ok
    TChar {}     -> ParseM (Type PName)
ok
    Type PName
TWild        -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"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
_  -> [Char] -> ParseM (Type PName)
forall a. [Char] -> ParseM a
bad [Char]
"kind annotation"
    TInfix{}     -> ParseM (Type PName)
ok

  where bad :: [Char] -> ParseM a
bad [Char]
x = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
rng [[Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be demoted."]
        ok :: ParseM (Type PName)
ok    = Type PName -> ParseM (Type PName)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type PName -> ParseM (Type PName))
-> Type PName -> ParseM (Type PName)
forall a b. (a -> b) -> a -> b
$ Range -> Type PName -> Type PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Range
rng Type PName
ty

-- | Input fields are reversed!
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
_)) -> Range -> [[Char]] -> ParseM b
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
nmRng [[Char]
"Record has repeated field: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
nm)]
     Right RecordMap Ident (Range, a)
r -> b -> ParseM b
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> ParseM b) -> b -> ParseM b
forall a b. (a -> b) -> a -> b
$ Range -> b -> b
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Range
rng (RecordMap Ident (Range, a) -> b
f RecordMap Ident (Range, a)
r)

  where
  res :: Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
res = [(Ident, (Range, a))]
-> Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
forall a b.
(Show a, Ord a) =>
[(a, b)] -> Either (a, b) (RecordMap a b)
recordFromFieldsErr [(Ident, (Range, a))]
ys
  ys :: [(Ident, (Range, a))]
ys = (Named a -> (Ident, (Range, a)))
-> [Named a] -> [(Ident, (Range, a))]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Named (Located Range
r Ident
nm) a
x) -> (Ident
nm,(Range
r,a
x))) ([Named a] -> [Named a]
forall a. [a] -> [a]
reverse [Named a]
xs)


-- | Input expression are reversed
mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)

mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)
mkEApp es :: NonEmpty (Expr PName)
es@(Expr PName
eLast :| [Expr PName]
_) =
    do Expr PName
f :| [Expr PName]
xs <- Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
eFirst [Expr PName]
rest
       Expr PName -> ParseM (Expr PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
eFirst,Expr PName
eLast) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ (Expr PName -> Expr PName -> Expr PName)
-> Expr PName -> [Expr PName] -> Expr PName
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f [Expr PName]
xs)

  where
  Expr PName
eFirst :| [Expr PName]
rest = NonEmpty (Expr PName) -> NonEmpty (Expr PName)
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty (Expr PName)
es

  {- Type applications are parsed as `ETypeVal (TTyApp fs)` expressions.
     Here we associate them with their corresponding functions,
     converting them into `EAppT` constructs.  For example:

     [ f, x, `{ a = 2 }, y ]
     becomes
     [ f, x ` { a = 2 }, y ]

     The parser associates field and tuple projectors that follow an
     explicit type application onto the TTyApp term, so we also
     have to unwind those projections and reapply them.  For example:

     [ f, x, `{ a = 2 }.f.2, y ]
     becomes
     [ f, (x`{ a = 2 }).f.2, y ]

  -}
  cvtTypeParams :: Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
e [] = NonEmpty (Expr PName) -> ParseM (NonEmpty (Expr PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr PName
e Expr PName -> [Expr PName] -> NonEmpty (Expr PName)
forall a. a -> [a] -> NonEmpty a
:| [])
  cvtTypeParams Expr PName
e (Expr PName
p : [Expr PName]
ps) =
    case Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
p Maybe Range
forall a. Maybe a
Nothing of
      Maybe ([TypeInst PName], [Selector], Maybe Range)
Nothing -> Expr PName -> NonEmpty (Expr PName) -> NonEmpty (Expr PName)
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Expr PName
e (NonEmpty (Expr PName) -> NonEmpty (Expr PName))
-> ParseM (NonEmpty (Expr PName)) -> ParseM (NonEmpty (Expr PName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
p [Expr PName]
ps

      Just ([TypeInst PName]
fs,[Selector]
ss,Maybe Range
rng) ->
        if Expr PName -> Bool
forall {n}. Expr n -> Bool
checkAppExpr Expr PName
e then
          let e' :: Expr PName
e'  = (Selector -> Expr PName -> Expr PName)
-> Expr PName -> [Selector] -> Expr PName
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Expr PName -> Selector -> Expr PName)
-> Selector -> Expr PName -> Expr PName
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr PName -> Selector -> Expr PName
forall n. Expr n -> Selector -> Expr n
ESel) (Expr PName -> [TypeInst PName] -> Expr PName
forall n. Expr n -> [TypeInst n] -> Expr n
EAppT Expr PName
e [TypeInst PName]
fs) [Selector]
ss
              e'' :: Expr PName
e'' = case Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e) Maybe Range
rng of
                      Just Range
r -> Expr PName -> Range -> Expr PName
forall n. Expr n -> Range -> Expr n
ELocated Expr PName
e' Range
r
                      Maybe Range
Nothing -> Expr PName
e'
           in Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
e'' [Expr PName]
ps
        else
          Range -> [[Char]] -> ParseM (NonEmpty (Expr PName))
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
emptyRange (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e))
                  [ [Char]
"Explicit type applications can only be applied to named values."
                  , [Char]
"Unexpected: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (Expr PName -> Doc
forall a. PP a => a -> Doc
pp Expr PName
e)
                  ]

  {- Check if the given expression is a legal target for explicit type application.
     This is basically only variables, but we also allow the parenthesis and
     the phantom "located" AST node.
   -}
  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

  {- Look under a potential chain of selectors to see if we have a TTyApp.
     If so, return the ty app information and the collected selectors
     to reapply.
   -}
  toTypeParam :: Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e Maybe Range
mr =
    case Expr PName
e of
      ELocated Expr PName
e' Range
rng -> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' (Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Maybe Range
mr (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
      ETypeVal Type PName
t -> Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall {a}.
Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr
      ESel Expr PName
e' Selector
s  -> ( \([TypeInst PName]
fs,[Selector]
ss,Maybe Range
r) -> ([TypeInst PName]
fs,Selector
sSelector -> [Selector] -> [Selector]
forall a. a -> [a] -> [a]
:[Selector]
ss,Maybe Range
r) ) (([TypeInst PName], [Selector], Maybe Range)
 -> ([TypeInst PName], [Selector], Maybe Range))
-> Maybe ([TypeInst PName], [Selector], Maybe Range)
-> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' Maybe Range
mr
      Expr PName
_          ->  Maybe ([TypeInst PName], [Selector], Maybe Range)
forall a. Maybe a
Nothing

  toTypeParam' :: Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr =
    case Type PName
t of
      TLocated Type PName
t' Range
rng -> Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t' (Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Maybe Range
mr (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
      TTyApp [Named (Type PName)]
fs -> ([TypeInst PName], [a], Maybe Range)
-> Maybe ([TypeInst PName], [a], Maybe Range)
forall a. a -> Maybe a
Just ((Named (Type PName) -> TypeInst PName)
-> [Named (Type PName)] -> [TypeInst PName]
forall a b. (a -> b) -> [a] -> [b]
map Named (Type PName) -> TypeInst PName
mkTypeInst [Named (Type PName)]
fs, [], Maybe Range
mr)
      Type PName
_ -> Maybe ([TypeInst PName], [a], Maybe Range)
forall a. Maybe a
Nothing

unOp :: Expr PName -> Expr PName -> Expr PName
unOp :: Expr PName -> Expr PName -> Expr PName
unOp Expr PName
f Expr PName
x = (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
f,Expr PName
x) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f Expr PName
x

-- Use defaultFixity as a placeholder, it will be fixed during renaming.
binOp :: Expr PName -> Located PName -> Expr PName -> Expr PName
binOp :: Expr PName -> LPName -> Expr PName -> Expr PName
binOp Expr PName
x LPName
f Expr PName
y = (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
x,Expr PName
y) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ Expr PName -> LPName -> Fixity -> Expr PName -> Expr PName
forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix Expr PName
x LPName
f Fixity
defaultFixity Expr PName
y

-- An element type ascription is allowed to appear on one of the arguments.
eFromTo :: Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> ParseM (Expr PName)
eFromTo :: Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> ParseM (Expr PName)
eFromTo Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 =
  case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped (Expr PName -> Maybe (Expr PName, Type PName))
-> Maybe (Expr PName) -> Maybe (Expr PName, Type PName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expr PName)
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1' Maybe (Expr PName)
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 (Expr PName -> Maybe (Expr PName)
forall a. a -> Maybe a
Just Expr PName
e2') Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> Range -> [[Char]] -> ParseM (Expr PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]
"A sequence enumeration may have at most one element type annotation."]

eFromToBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToBy :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Bool
-> ParseM (Expr PName)
eFromToBy Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Bool
isStrictBound =
  case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1' Expr PName
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2' Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing)       -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing Bool
isStrictBound
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> Range -> [[Char]] -> ParseM (Expr PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]
"A sequence enumeration may have at most one element type annotation."]

eFromToByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToByTyped :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
t Bool
isStrictBound =
  Bool
-> Type PName
-> Type PName
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToBy Bool
isStrictBound
      (Type PName
 -> Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM
     (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
      ParseM
  (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
      ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
      ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t

eFromToDownBy ::
  Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToDownBy :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Bool
-> ParseM (Expr PName)
eFromToDownBy Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Bool
isStrictBound =
  case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1' Expr PName
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2' Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing)       -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing Bool
isStrictBound
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> Range -> [[Char]] -> ParseM (Expr PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]
"A sequence enumeration may have at most one element type annotation."]

eFromToDownByTyped ::
  Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToDownByTyped :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
t Bool
isStrictBound =
  Bool
-> Type PName
-> Type PName
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToDownBy Bool
isStrictBound
      (Type PName
 -> Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM
     (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
      ParseM
  (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
      ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
      ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall a. a -> ParseM a
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
_) = Expr n -> Maybe (Expr n, Type n)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr n
e
asETyped (ETyped Expr n
e Type n
t) = (Expr n, Type n) -> Maybe (Expr n, Type n)
forall a. a -> Maybe a
Just (Expr n
e, Type n
t)
asETyped Expr n
_ = Maybe (Expr n, Type n)
forall a. Maybe a
Nothing

eFromToType ::
  Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType :: Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 Maybe (Type PName)
t =
  Type PName
-> Maybe (Type PName)
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Type n -> Maybe (Type n) -> Type n -> Maybe (Type n) -> Expr n
EFromTo (Type PName
 -> Maybe (Type PName)
 -> Type PName
 -> Maybe (Type PName)
 -> Expr PName)
-> ParseM (Type PName)
-> ParseM
     (Maybe (Type PName)
      -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
          ParseM
  (Maybe (Type PName)
   -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName))
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr PName -> ParseM (Type PName))
-> Maybe (Expr PName) -> ParseM (Maybe (Type PName))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r) Maybe (Expr PName)
e2
          ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
          ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t

eFromToLessThan ::
  Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan :: Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan Range
r Expr PName
e1 Expr PName
e2 =
  case Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2 of
    Just (Expr PName, Type PName)
_  -> Range -> [[Char]] -> ParseM (Expr PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]
"The exclusive upper bound of an enumeration may not have a type annotation."]
    Maybe (Expr PName, Type PName)
Nothing ->
      case Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1 of
        Maybe (Expr PName, Type PName)
Nothing      -> Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1  Expr PName
e2 Maybe (Type PName)
forall a. Maybe a
Nothing
        Just (Expr PName
e1',Type PName
t) -> Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1' Expr PName
e2 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)

eFromToLessThanType ::
  Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToLessThanType :: Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1 Expr PName
e2 Maybe (Type PName)
t =
  Type PName -> Type PName -> Maybe (Type PName) -> Expr PName
forall n. Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToLessThan
    (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
    ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
    ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t

exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
expr =
  case Expr PName -> Maybe (Type PName)
translateExprToNumT Expr PName
expr of
    Just Type PName
t -> Type PName -> ParseM (Type PName)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
    Maybe (Type PName)
Nothing -> ParseM (Type PName)
forall a. ParseM a
bad
  where
  bad :: ParseM a
bad = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
r (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
expr))
        [ [Char]
"The boundaries of .. sequences should be valid numeric types."
        , [Char]
"The expression `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (Expr PName -> Doc
forall a. PP a => a -> Doc
pp Expr PName
expr) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` is not."
        ]


-- | WARNING: This is a bit of a hack.
-- It is used to represent anonymous type applications.
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp ~(Just Range
r) [Type PName]
ts = Type PName -> Range -> Type PName
forall n. Type n -> Range -> Type n
TLocated ([Named (Type PName)] -> Type PName
forall n. [Named (Type n)] -> Type n
TTyApp ((Type PName -> Named (Type PName))
-> [Type PName] -> [Named (Type PName)]
forall a b. (a -> b) -> [a] -> [b]
map Type PName -> Named (Type PName)
forall {a}. a -> Named a
toField [Type PName]
ts)) Range
r
  where noName :: Located Ident
noName    = Located { srcRange :: Range
srcRange = Range
r, thing :: Ident
thing = Text -> Ident
mkIdent ([Char] -> Text
T.pack [Char]
"") }
        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 = TopLevel (Decl PName) -> TopDecl PName
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 = TopLevel (Newtype PName) -> TopDecl PName
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 }

exportEnum ::
  ExportType -> Maybe (Located Text) -> EnumDecl PName -> TopDecl PName
exportEnum :: ExportType
-> Maybe (Located Text) -> EnumDecl PName -> TopDecl PName
exportEnum ExportType
e Maybe (Located Text)
d EnumDecl PName
n = TopLevel (EnumDecl PName) -> TopDecl PName
forall name. TopLevel (EnumDecl name) -> TopDecl name
TDEnum TopLevel { tlExport :: ExportType
tlExport = ExportType
e
                                   , tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
d
                                   , tlValue :: EnumDecl PName
tlValue = EnumDecl PName
n }

exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule Maybe (Located Text)
mbDoc NestedModule PName
m = TopLevel (NestedModule PName) -> TopDecl PName
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel { 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 = ParameterFun PName -> ParamDecl PName
forall name. ParameterFun name -> ParamDecl name
DParameterFun ParameterFun { pfName :: LPName
pfName = LPName
n
                                                , pfSchema :: Schema PName
pfSchema = Schema PName
s
                                                , pfDoc :: Maybe Text
pfDoc = Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
                                                , pfFixity :: Maybe Fixity
pfFixity = Maybe Fixity
forall a. Maybe a
Nothing
                                                }

mkParType :: Maybe (Located Text) ->
             Located PName ->
             Located Kind ->
             ParseM (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 <- (Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (Int, S))
 -> ParseM Int)
-> (Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
s -> let nu :: Int
nu = S -> Int
sNextTyParamNum S
s
                          in (Int, S) -> Either ParseError (Int, S)
forall a b. b -> Either a b
Right (Int
nu, S
s { sNextTyParamNum = nu + 1 })
     ParamDecl PName -> ParseM (ParamDecl PName)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParameterType PName -> ParamDecl PName
forall name. ParameterType name -> ParamDecl name
DParameterType
             ParameterType { ptName :: LPName
ptName    = LPName
n
                           , ptKind :: Kind
ptKind    = Located Kind -> Kind
forall a. Located a -> a
thing Located Kind
k
                           , ptDoc :: Maybe Text
ptDoc     = Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
                           , ptFixity :: Maybe Fixity
ptFixity  = Maybe Fixity
forall a. Maybe a
Nothing
                           , ptNumber :: Int
ptNumber  = Int
num
                           })

changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport ExportType
e = (TopDecl PName -> TopDecl PName)
-> [TopDecl PName] -> [TopDecl PName]
forall a b. (a -> b) -> [a] -> [b]
map TopDecl PName -> TopDecl PName
forall {name}. TopDecl name -> TopDecl name
change
  where
  change :: TopDecl name -> TopDecl name
change TopDecl name
decl =
    case TopDecl name
decl of
      Decl TopLevel (Decl name)
d                  -> TopLevel (Decl name) -> TopDecl name
forall name. TopLevel (Decl name) -> TopDecl name
Decl      TopLevel (Decl name)
d { tlExport = e }
      DPrimType TopLevel (PrimType name)
t             -> TopLevel (PrimType name) -> TopDecl name
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType name)
t { tlExport = e }
      TDNewtype TopLevel (Newtype name)
n             -> TopLevel (Newtype name) -> TopDecl name
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel (Newtype name)
n { tlExport = e }
      TDEnum TopLevel (EnumDecl name)
n                -> TopLevel (EnumDecl name) -> TopDecl name
forall name. TopLevel (EnumDecl name) -> TopDecl name
TDEnum    TopLevel (EnumDecl name)
n { tlExport = e }
      DModule TopLevel (NestedModule name)
m               -> TopLevel (NestedModule name) -> TopDecl name
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule   TopLevel (NestedModule name)
m { tlExport = 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 (Located Ident -> Ident
forall a. Located a -> a
thing (Named (Type PName) -> Located Ident
forall a. Named a -> Located Ident
name Named (Type PName)
x)) = Type PName -> TypeInst PName
forall name. Type name -> TypeInst name
PosInst (Named (Type PName) -> Type PName
forall a. Named a -> a
value Named (Type PName)
x)
             | Bool
otherwise                  = Named (Type PName) -> TypeInst PName
forall name. Named (Type name) -> TypeInst name
NamedInst Named (Type PName)
x


mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam Located { srcRange :: forall a. Located a -> Range
srcRange = Range
rng, thing :: forall a. Located a -> a
thing = Ident
n } Maybe Kind
k
  | Ident
n Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent = Range -> [[Char]] -> ParseM (TParam PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
rng [[Char]
"`width` is not a valid type parameter name."]
  | Bool
otherwise       = TParam PName -> ParseM (TParam PName)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Maybe Kind -> Maybe Range -> TParam PName
forall n. n -> Maybe Kind -> Maybe Range -> TParam n
TParam (Ident -> PName
mkUnqual Ident
n) Maybe Kind
k (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))


mkTySyn :: 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
     Decl PName -> ParseM (Decl PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TySyn PName -> Decl PName
forall name. TySyn name -> Decl name
DType (LPName
-> Maybe Fixity -> [TParam PName] -> Type PName -> TySyn PName
forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn LPName
nm Maybe Fixity
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          <- Located [Prop PName] -> [Prop PName]
forall a. Located a -> a
thing (Located [Prop PName] -> [Prop PName])
-> ParseM (Located [Prop PName]) -> ParseM [Prop PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
tdef
     Decl PName -> ParseM (Decl PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PropSyn PName -> Decl PName
forall name. PropSyn name -> Decl name
DProp (LPName
-> Maybe Fixity -> [TParam PName] -> [Prop PName] -> PropSyn PName
forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn LPName
nm Maybe Fixity
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
     Newtype PName -> ParseM (Newtype PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LPName
-> [TParam PName]
-> PName
-> RecordMap Ident (Range, Type PName)
-> Newtype PName
forall name.
Located name
-> [TParam name] -> name -> Rec (Type name) -> Newtype name
Newtype LPName
nm [TParam PName]
params (LPName -> PName
forall a. Located a -> a
thing LPName
nm) (Located (RecordMap Ident (Range, Type PName))
-> RecordMap Ident (Range, Type PName)
forall a. Located a -> a
thing Located (RecordMap Ident (Range, Type PName))
def))

mkEnumDecl ::
  Type PName ->
  [ TopLevel (EnumCon PName) ] {- ^ Reversed -} ->
  ParseM (EnumDecl PName)
mkEnumDecl :: Type PName -> [TopLevel (EnumCon PName)] -> ParseM (EnumDecl PName)
mkEnumDecl Type PName
thead [TopLevel (EnumCon PName)]
def =
  do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
     ((PName, [Range]) -> ParseM ()) -> [(PName, [Range])] -> ParseM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PName, [Range]) -> ParseM ()
forall {a}. PP a => (a, [Range]) -> ParseM ()
reportRepeated
        (Map PName [Range] -> [(PName, [Range])]
forall k a. Map k a -> [(k, a)]
Map.toList (([Range] -> [Range] -> [Range])
-> [(PName, [Range])] -> Map PName [Range]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Range] -> [Range] -> [Range]
forall a. [a] -> [a] -> [a]
(++) [ (LPName -> PName
forall a. Located a -> a
thing LPName
k,[LPName -> Range
forall a. Located a -> Range
srcRange LPName
k])
                                           | LPName
k <- (TopLevel (EnumCon PName) -> LPName)
-> [TopLevel (EnumCon PName)] -> [LPName]
forall a b. (a -> b) -> [a] -> [b]
map (EnumCon PName -> LPName
forall name. EnumCon name -> Located name
ecName (EnumCon PName -> LPName)
-> (TopLevel (EnumCon PName) -> EnumCon PName)
-> TopLevel (EnumCon PName)
-> LPName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel (EnumCon PName) -> EnumCon PName
forall a. TopLevel a -> a
tlValue) [TopLevel (EnumCon PName)]
def ]))
     EnumDecl PName -> ParseM (EnumDecl PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumDecl
            { eName :: LPName
eName   = LPName
nm
            , eParams :: [TParam PName]
eParams = [TParam PName]
params
            , eCons :: [TopLevel (EnumCon PName)]
eCons   = [TopLevel (EnumCon PName)] -> [TopLevel (EnumCon PName)]
forall a. [a] -> [a]
reverse [TopLevel (EnumCon PName)]
def
            }
  where
  reportRepeated :: (a, [Range]) -> ParseM ()
reportRepeated (a
i,[Range]
xs) =
    case [Range]
xs of
      Range
l : ls :: [Range]
ls@(Range
_ : [Range]
_) ->
        Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
l
          ( ([Char]
"Multiple declarations for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (Doc -> Doc
backticks (a -> Doc
forall a. PP a => a -> Doc
pp a
i)))
          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [ [Char]
"Other declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (Range -> Doc
forall a. PP a => a -> Doc
pp Range
x) | Range
x <- [Range]
ls ]
          )

      [Range]
_ -> () -> ParseM ()
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mkConDecl ::
  Maybe (Located Text) -> ExportType ->
  Type PName -> ParseM (TopLevel (EnumCon PName))
mkConDecl :: Maybe (Located Text)
-> ExportType -> Type PName -> ParseM (TopLevel (EnumCon PName))
mkConDecl Maybe (Located Text)
mbDoc ExportType
expT Type PName
ty =
  do EnumCon PName
con <- Maybe Range -> Type PName -> ParseM (EnumCon PName)
go Maybe Range
forall a. Maybe a
Nothing Type PName
ty
     TopLevel (EnumCon PName) -> ParseM (TopLevel (EnumCon PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TopLevel { tlExport :: ExportType
tlExport = ExportType
expT, tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
mbDoc, tlValue :: EnumCon PName
tlValue = EnumCon PName
con }
  where
  go :: Maybe Range -> Type PName -> ParseM (EnumCon PName)
go Maybe Range
mbLoc Type PName
t =
    case Type PName
t of
      TLocated Type PName
t1 Range
r -> Maybe Range -> Type PName -> ParseM (EnumCon PName)
go (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
r) Type PName
t1
      TUser PName
n [Type PName]
ts ->
        case PName
n of
          UnQual Ident
i
            | Ident -> Bool
isUpperIdent Ident
i ->
              EnumCon PName -> ParseM (EnumCon PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumCon { ecName :: LPName
ecName = Range -> PName -> LPName
forall a. Range -> a -> Located a
Located (Maybe Range -> Range
forall {a}. Maybe a -> a
getL Maybe Range
mbLoc) (Ident -> PName
UnQual Ident
i)
                           , ecFields :: [Type PName]
ecFields = [Type PName]
ts
                           }
            | Bool
otherwise ->
              Range -> [[Char]] -> ParseM (EnumCon PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Maybe Range -> Range
forall {a}. Maybe a -> a
getL Maybe Range
mbLoc)
                 [ [Char]
"Malformed constructor declaration."
                 , [Char]
"The constructor name should start with a capital letter."
                 ]

          PName
_ -> Range -> [[Char]] -> ParseM (EnumCon PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Maybe Range -> Range
forall {a}. Maybe a -> a
getL Maybe Range
mbLoc)
                 [ [Char]
"Malformed constructor declaration."
                 , [Char]
"The constructor name may not be qualified."
                 ]
      Type PName
_ -> Range -> [[Char]] -> ParseM (EnumCon PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Maybe Range -> Range
forall {a}. Maybe a -> a
getL Maybe Range
mbLoc) [ [Char]
"Malformed constructor declaration." ]

  getL :: Maybe a -> a
getL Maybe a
mb =
    case Maybe a
mb of
      Just a
r  -> a
r
      Maybe a
Nothing -> [Char] -> [[Char]] -> a
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"mkConDecl" [[Char]
"Missing type location"]


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
_ -> [Char] -> [[Char]] -> ParseM (LPName, [TParam PName])
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"typeToDecl" [[Char]
"Type location is missing."]

  where
  bad :: Range -> ParseM a
bad Range
loc  = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
loc [[Char]
"Invalid type declaration"]
  badP :: Range -> ParseM a
badP Range
loc = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
loc [[Char]
"Invalid declaration parameter"]


  goN :: Range -> PName -> ParseM ()
goN Range
loc PName
n =
    case PName
n of
      UnQual {} -> () -> ParseM ()
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PName
_         -> Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
loc [[Char]
"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
           TParam PName -> ParseM (TParam PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TParam { tpName :: PName
tpName = PName
f, tpKind :: Maybe Kind
tpKind = Maybe Kind
forall a. Maybe a
Nothing, tpRange :: Maybe Range
tpRange = Range -> Maybe Range
forall a. a -> Maybe a
Just Range
loc }

      TParens Type PName
t Maybe Kind
mb ->
        case Maybe Kind
mb of
          Maybe Kind
Nothing -> Range -> ParseM (TParam PName)
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 TParam PName -> Maybe Kind
forall n. TParam n -> Maybe Kind
tpKind TParam PName
p of
                 Maybe Kind
Nothing -> TParam PName -> ParseM (TParam PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TParam PName
p { tpKind = Just k }
                 Just {} -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc

      TInfix {}     -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TUser {}      -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TFun {}       -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TSeq {}       -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TBit {}       -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TNum {}       -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TChar {}      -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TRecord {}    -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TWild {}      -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TTyApp {}     -> Range -> ParseM (TParam PName)
forall {a}. Range -> ParseM a
badP Range
loc
      TTuple {}     -> Range -> ParseM (TParam PName)
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 <- (Type PName -> ParseM (TParam PName))
-> [Type PName] -> ParseM [TParam PName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Range -> Type PName -> ParseM (TParam PName)
goP Range
loc) [Type PName]
ts
           (LPName, [TParam PName]) -> ParseM (LPName, [TParam PName])
forall a. a -> ParseM a
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 (LPName -> Range
forall a. Located a -> Range
srcRange LPName
f) (LPName -> PName
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
           (LPName, [TParam PName]) -> ParseM (LPName, [TParam PName])
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LPName
f,[TParam PName
a,TParam PName
b])

      TFun {}       -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TSeq {}       -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TBit {}       -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TNum {}       -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TChar {}      -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TRecord {}    -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TWild {}      -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TTyApp {}     -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TTuple {}     -> Range -> ParseM (LPName, [TParam PName])
forall {a}. Range -> ParseM a
bad Range
loc
      TParens {}    -> Range -> ParseM (LPName, [TParam PName])
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 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0          = (Bool, Integer) -> ParseM (Bool, Integer)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Integer
p)
  | Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1          = (Bool, Integer) -> ParseM (Bool, Integer)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Integer
p)
  | Bool
otherwise       = Range -> [[Char]] -> ParseM (Bool, Integer)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
rng [[Char]
"Invalid polynomial coefficient"]

mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly :: Range -> [(Bool, Integer)] -> ParseM (Expr PName)
mkPoly Range
rng [(Bool, Integer)]
terms
  | Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) = Integer -> [Int] -> ParseM (Expr PName)
mk Integer
0 ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a. Num a => Integer -> a
fromInteger [Integer]
bits)
  | Bool
otherwise = Range -> [[Char]] -> ParseM (Expr PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
rng [[Char]
"Polynomial literal too large: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
w]

  where
  w :: Integer
w    = case [(Bool, Integer)]
terms of
           [] -> Integer
0
           [(Bool, Integer)]
_  -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((Bool, Integer) -> Integer) -> [(Bool, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Integer) -> Integer
forall a b. (a, b) -> b
snd [(Bool, Integer)]
terms)

  bits :: [Integer]
bits = [ Integer
n | (Bool
True,Integer
n) <- [(Bool, Integer)]
terms ]

  mk :: Integer -> [Int] -> ParseM (Expr PName)
  mk :: Integer -> [Int] -> ParseM (Expr PName)
mk Integer
res [] = Expr PName -> ParseM (Expr PName)
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr PName -> ParseM (Expr PName))
-> Expr PName -> ParseM (Expr PName)
forall a b. (a -> b) -> a -> b
$ Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
res (Int -> NumInfo
PolyLit (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
w :: Int))

  mk Integer
res (Int
n : [Int]
ns)
    | Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
res Int
n = Range -> [[Char]] -> ParseM (Expr PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
rng
                       [[Char]
"Polynomial contains multiple terms with exponent " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n]
    | Bool
otherwise     = Integer -> [Int] -> ParseM (Expr PName)
mk (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
setBit Integer
res Int
n) [Int]
ns


-- NOTE: The list of patterns is reversed!
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty LPName
f [Pattern PName]
ps Expr PName
e = (LPName, Expr PName) -> Decl PName -> Decl PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (LPName
f,Expr PName
e) (Decl PName -> Decl PName) -> Decl PName -> Decl PName
forall a b. (a -> b) -> a -> b
$
                    Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName       = LPName
f
                               , bParams :: [Pattern PName]
bParams     = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
                               , bDef :: Located (BindDef PName)
bDef        = Expr PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange (Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
exprDef Expr PName
e))
                               , bSignature :: Maybe (Schema PName)
bSignature  = Maybe (Schema PName)
forall a. Maybe a
Nothing
                               , bPragmas :: [Pragma]
bPragmas    = [Pragma
PragmaProperty]
                               , bMono :: Bool
bMono       = Bool
False
                               , bInfix :: Bool
bInfix      = Bool
False
                               , bFixity :: Maybe Fixity
bFixity     = Maybe Fixity
forall a. Maybe a
Nothing
                               , bDoc :: Maybe Text
bDoc        = Maybe Text
forall a. Maybe a
Nothing
                               , bExport :: ExportType
bExport     = ExportType
Public
                               }

-- NOTE: The lists of patterns are reversed!
mkIndexedDecl ::
  LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl :: LPName
-> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl LPName
f ([Pattern PName]
ps, [Pattern PName]
ixs) Expr PName
e =
  Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName       = LPName
f
             , bParams :: [Pattern PName]
bParams     = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
             , bDef :: Located (BindDef PName)
bDef        = Expr PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange (Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
exprDef Expr PName
rhs))
             , bSignature :: Maybe (Schema PName)
bSignature  = Maybe (Schema PName)
forall a. Maybe a
Nothing
             , bPragmas :: [Pragma]
bPragmas    = []
             , bMono :: Bool
bMono       = Bool
False
             , bInfix :: Bool
bInfix      = Bool
False
             , bFixity :: Maybe Fixity
bFixity     = Maybe Fixity
forall a. Maybe a
Nothing
             , bDoc :: Maybe Text
bDoc        = Maybe Text
forall a. Maybe a
Nothing
             , bExport :: ExportType
bExport     = ExportType
Public
             }
  where
    rhs :: Expr PName
    rhs :: Expr PName
rhs = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
e

-- NOTE: The lists of patterns are reversed!
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 Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Pattern PName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ixs) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
      Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
f)
                  [[Char]
"Indexed sequence definitions may not use constraint guards"]
     let gs :: [PropGuardCase PName]
gs  = [PropGuardCase PName] -> [PropGuardCase PName]
forall a. [a] -> [a]
reverse [PropGuardCase PName]
guards
     Decl PName -> ParseM (Decl PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decl PName -> ParseM (Decl PName))
-> Decl PName -> ParseM (Decl PName)
forall a b. (a -> b) -> a -> b
$
       Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName       = LPName
f
                  , bParams :: [Pattern PName]
bParams     = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
                  , bDef :: Located (BindDef PName)
bDef        = Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located (LPName -> Range
forall a. Located a -> Range
srcRange LPName
f) (BindImpl PName -> BindDef PName
forall name. BindImpl name -> BindDef name
DImpl ([PropGuardCase PName] -> BindImpl PName
forall name. [PropGuardCase name] -> BindImpl name
DPropGuards [PropGuardCase PName]
gs))
                  , bSignature :: Maybe (Schema PName)
bSignature  = Maybe (Schema PName)
forall a. Maybe a
Nothing
                  , bPragmas :: [Pragma]
bPragmas    = []
                  , bMono :: Bool
bMono       = Bool
False
                  , bInfix :: Bool
bInfix      = Bool
False
                  , bFixity :: Maybe Fixity
bFixity     = Maybe Fixity
forall a. Maybe a
Nothing
                  , bDoc :: Maybe Text
bDoc        = Maybe Text
forall a. Maybe a
Nothing
                  , bExport :: ExportType
bExport     = ExportType
Public
                  }

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

-- NOTE: The lists of patterns are reversed!
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr ([Pattern PName]
ps, [Pattern PName]
ixs) Expr PName
body
  | [Pattern PName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ps = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body
  | Bool
otherwise = FunDesc PName -> [Pattern PName] -> Expr PName -> Expr PName
forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
forall n. FunDesc n
emptyFunDesc ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps) ([Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body)

mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate [Pattern PName]
pats Expr PName
body =
  (Pattern PName -> Expr PName -> Expr PName)
-> Expr PName -> [Pattern PName] -> Expr PName
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pattern PName
pat Expr PName
e -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EGenerate (FunDesc PName -> [Pattern PName] -> Expr PName -> Expr PName
forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
forall n. FunDesc n
emptyFunDesc [Pattern PName
pat] Expr PName
e)) Expr PName
body [Pattern PName]
pats

mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf [(Expr PName, Expr PName)]
ifThens Expr PName
theElse = ((Expr PName, Expr PName) -> Expr PName -> Expr PName)
-> Expr PName -> [(Expr PName, Expr PName)] -> Expr PName
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall {n}. (Expr n, Expr n) -> Expr n -> Expr n
addIfThen Expr PName
theElse [(Expr PName, Expr PName)]
ifThens
    where
    addIfThen :: (Expr n, Expr n) -> Expr n -> Expr n
addIfThen (Expr n
cond, Expr n
doexpr) Expr n
elseExpr = Expr n -> Expr n -> Expr n -> Expr n
forall n. Expr n -> Expr n -> Expr n -> Expr n
EIf Expr n
cond Expr n
doexpr Expr n
elseExpr

mkPVar :: Located PName -> Pattern PName
mkPVar :: LPName -> Pattern PName
mkPVar LPName
p =
  case LPName -> PName
forall a. Located a -> a
thing LPName
p of
    UnQual Ident
i | Ident -> Bool
isInfixIdent Ident
i Bool -> Bool -> Bool
|| Bool -> Bool
not (Ident -> Bool
isUpperIdent Ident
i) -> LPName -> Pattern PName
forall n. Located n -> Pattern n
PVar LPName
p
    PName
_ -> LPName -> [Pattern PName] -> Pattern PName
forall n. Located n -> [Pattern n] -> Pattern n
PCon LPName
p []

mkIPat :: Pattern PName -> ParseM (Pattern PName)
mkIPat :: Pattern PName -> ParseM (Pattern PName)
mkIPat Pattern PName
pat =
  case Pattern PName
pat of
    PVar {}      -> Pattern PName -> ParseM (Pattern PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pattern PName
pat
    Pattern PName
PWild        -> Pattern PName -> ParseM (Pattern PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pattern PName
pat
    PTuple [Pattern PName]
ps    -> [Pattern PName] -> Pattern PName
forall n. [Pattern n] -> Pattern n
PTuple ([Pattern PName] -> Pattern PName)
-> ParseM [Pattern PName] -> ParseM (Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern PName -> ParseM (Pattern PName))
-> [Pattern PName] -> ParseM [Pattern PName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Pattern PName -> ParseM (Pattern PName)
mkIPat [Pattern PName]
ps
    PRecord Rec (Pattern PName)
rp   -> Rec (Pattern PName) -> Pattern PName
forall n. Rec (Pattern n) -> Pattern n
PRecord (Rec (Pattern PName) -> Pattern PName)
-> ParseM (Rec (Pattern PName)) -> ParseM (Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> (Range, Pattern PName) -> ParseM (Range, Pattern PName))
-> Rec (Pattern PName) -> ParseM (Rec (Pattern PName))
forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> t c) -> RecordMap a b -> t (RecordMap a c)
traverseRecordMap Ident -> (Range, Pattern PName) -> ParseM (Range, Pattern PName)
forall {p} {a}.
p -> (a, Pattern PName) -> ParseM (a, Pattern PName)
upd Rec (Pattern PName)
rp
      where upd :: p -> (a, Pattern PName) -> ParseM (a, Pattern PName)
upd p
_ (a
x,Pattern PName
y) = (,) a
x (Pattern PName -> (a, Pattern PName))
-> ParseM (Pattern PName) -> ParseM (a, Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PName -> ParseM (Pattern PName)
mkIPat Pattern PName
y
    PList [Pattern PName]
ps     -> [Pattern PName] -> Pattern PName
forall n. [Pattern n] -> Pattern n
PList ([Pattern PName] -> Pattern PName)
-> ParseM [Pattern PName] -> ParseM (Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern PName -> ParseM (Pattern PName))
-> [Pattern PName] -> ParseM [Pattern PName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Pattern PName -> ParseM (Pattern PName)
mkIPat [Pattern PName]
ps
    PTyped Pattern PName
p Type PName
t   -> (Pattern PName -> Type PName -> Pattern PName
forall n. Pattern n -> Type n -> Pattern n
`PTyped` Type PName
t) (Pattern PName -> Pattern PName)
-> ParseM (Pattern PName) -> ParseM (Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PName -> ParseM (Pattern PName)
mkIPat Pattern PName
p
    PSplit Pattern PName
p1 Pattern PName
p2 -> Pattern PName -> Pattern PName -> Pattern PName
forall n. Pattern n -> Pattern n -> Pattern n
PSplit (Pattern PName -> Pattern PName -> Pattern PName)
-> ParseM (Pattern PName)
-> ParseM (Pattern PName -> Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PName -> ParseM (Pattern PName)
mkIPat Pattern PName
p1 ParseM (Pattern PName -> Pattern PName)
-> ParseM (Pattern PName) -> ParseM (Pattern PName)
forall a b. ParseM (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern PName -> ParseM (Pattern PName)
mkIPat Pattern PName
p2
    PLocated Pattern PName
p Range
r -> (Pattern PName -> Range -> Pattern PName
forall n. Pattern n -> Range -> Pattern n
`PLocated` Range
r) (Pattern PName -> Pattern PName)
-> ParseM (Pattern PName) -> ParseM (Pattern PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PName -> ParseM (Pattern PName)
mkIPat Pattern PName
p
    PCon LPName
n [Pattern PName]
ps    ->
      case [Pattern PName]
ps of
        [] | UnQual {} <- LPName -> PName
forall a. Located a -> a
thing LPName
n -> Pattern PName -> ParseM (Pattern PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LPName -> Pattern PName
forall n. Located n -> Pattern n
PVar LPName
n)
        [Pattern PName]
_ -> Range -> [[Char]] -> ParseM (Pattern PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
n)
               [ [Char]
"Unexpected constructor pattern."
               , [Char]
"Constructors patterns may be used only in `case` expressions."
               ]



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 BindDef PName
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 :: [Char]
txt = Ident -> [Char]
unpackIdent (PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
nm))
     Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isOk [Char]
txt)
       (Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
nm)
            [ [Char]
"`" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
txt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` is not a valid foreign name."
            , [Char]
"The name should contain only alpha-numeric characters or '_'."
            ])
     -- We do allow optional cryptol implementations of foreign functions, these
     -- will be merged with this binding in the NoPat pass. In the parser they
     -- are just treated as a completely separate (non-foreign) binding with the
     -- same name.
     [TopDecl PName] -> ParseM [TopDecl PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BindDef PName
-> Maybe (Located Text)
-> LPName
-> Schema PName
-> [TopDecl PName]
mkNoImplDecl (Maybe (BindImpl PName) -> BindDef PName
forall name. Maybe (BindImpl name) -> BindDef name
DForeign Maybe (BindImpl PName)
forall a. Maybe a
Nothing) Maybe (Located Text)
mbDoc LPName
nm Schema PName
ty)
  where
  isOk :: Char -> Bool
isOk Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c

-- | Generate a signature and a binding for value declarations with no
-- implementation (i.e. primitive or foreign declarations).  The reason for
-- generating both instead of just adding the signature at this point is that it
-- means the declarations don't need to be treated differently in the noPat
-- pass.  This is also the reason we add the doc to the TopLevel constructor,
-- instead of just place it on the binding directly.  A better solution might be
-- to just have a different constructor for primitives and foreigns.
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)
forall a. Maybe a
Nothing ExportType
Public
    (Decl PName -> TopDecl PName) -> Decl PName -> TopDecl PName
forall a b. (a -> b) -> a -> b
$ Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName      = LPName
ln
                 , bParams :: [Pattern PName]
bParams    = []
                 , bDef :: Located (BindDef PName)
bDef       = Schema PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Schema PName
sig (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange BindDef PName
def)
                 , bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing
                 , bPragmas :: [Pragma]
bPragmas   = []
                 , bMono :: Bool
bMono      = Bool
False
                 , bInfix :: Bool
bInfix     = Ident -> Bool
isInfixIdent (PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln))
                 , bFixity :: Maybe Fixity
bFixity    = Maybe Fixity
forall a. Maybe a
Nothing
                 , bDoc :: Maybe Text
bDoc       = Maybe Text
forall a. Maybe a
Nothing
                 , bExport :: ExportType
bExport    = ExportType
Public
                 }
  , Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
Public
    (Decl PName -> TopDecl PName) -> Decl PName -> TopDecl PName
forall a b. (a -> b) -> a -> b
$ [LPName] -> Schema PName -> Decl PName
forall name. [Located name] -> Schema name -> Decl name
DSignature [LPName
ln] Schema PName
sig
  ]

mkPrimTypeDecl ::
  Maybe (Located Text) ->
  Schema PName ->
  Located Kind ->
  ParseM [TopDecl PName]
mkPrimTypeDecl :: Maybe (Located Text)
-> Schema PName -> Located Kind -> ParseM [TopDecl PName]
mkPrimTypeDecl Maybe (Located Text)
mbDoc (Forall [TParam PName]
as [Prop PName]
qs Type PName
st ~(Just Range
schema_rng)) Located Kind
finK =
  case Range -> Type PName -> Maybe (LPName, [LPName])
forall {a}.
Eq a =>
Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
schema_rng Type PName
st of
    Just (LPName
n,[LPName]
xs) ->
      do [(PName, (TParam PName, Kind))]
vs <- (TParam PName -> ParseM (PName, (TParam PName, Kind)))
-> [TParam PName] -> ParseM [(PName, (TParam PName, Kind))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TParam PName -> ParseM (PName, (TParam PName, Kind))
forall {n}. TParam n -> ParseM (n, (TParam n, Kind))
tpK [TParam PName]
as
         Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PName] -> Bool
forall {a}. Eq a => [a] -> Bool
distinct (((PName, (TParam PName, Kind)) -> PName)
-> [(PName, (TParam PName, Kind))] -> [PName]
forall a b. (a -> b) -> [a] -> [b]
map (PName, (TParam PName, Kind)) -> PName
forall a b. (a, b) -> a
fst [(PName, (TParam PName, Kind))]
vs)) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
            Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
schema_rng [[Char]
"Repeated parameters."]
         let kindMap :: Map PName (TParam PName, Kind)
kindMap = [(PName, (TParam PName, Kind))] -> Map PName (TParam PName, Kind)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PName, (TParam PName, Kind))]
vs
             lkp :: LPName -> ParseM (TParam PName, Kind)
lkp LPName
v = case PName
-> Map PName (TParam PName, Kind) -> Maybe (TParam PName, Kind)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LPName -> PName
forall a. Located a -> a
thing LPName
v) Map PName (TParam PName, Kind)
kindMap of
                       Just (TParam PName
k,Kind
tp)  -> (TParam PName, Kind) -> ParseM (TParam PName, Kind)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam PName
k,Kind
tp)
                       Maybe (TParam PName, Kind)
Nothing ->
                        Range -> [[Char]] -> ParseM (TParam PName, Kind)
forall a. Range -> [[Char]] -> ParseM a
errorMessage
                            (LPName -> Range
forall a. Located a -> Range
srcRange LPName
v)
                            [[Char]
"Undefined parameter: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (PName -> Doc
forall a. PP a => a -> Doc
pp (LPName -> PName
forall a. Located a -> a
thing LPName
v))]
         ([TParam PName]
as',[Kind]
ins) <- [(TParam PName, Kind)] -> ([TParam PName], [Kind])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TParam PName, Kind)] -> ([TParam PName], [Kind]))
-> ParseM [(TParam PName, Kind)] -> ParseM ([TParam PName], [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LPName -> ParseM (TParam PName, Kind))
-> [LPName] -> ParseM [(TParam PName, Kind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LPName -> ParseM (TParam PName, Kind)
lkp [LPName]
xs
         Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PName, (TParam PName, Kind))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PName, (TParam PName, Kind))]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [LPName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPName]
xs) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
           Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
schema_rng [[Char]
"All parameters should appear in the type."]

         let ki :: Located Kind
ki = Located Kind
finK { thing = foldr KFun (thing finK) ins }

         [TopDecl PName] -> ParseM [TopDecl PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TopLevel (PrimType PName) -> TopDecl PName
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 = Maybe Fixity
forall a. Maybe a
Nothing
                                        }
                 }
              ]

    Maybe (LPName, [LPName])
Nothing -> Range -> [[Char]] -> ParseM [TopDecl PName]
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
schema_rng [[Char]
"Invalid primitive signature"]

  where
  splitT :: Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r Type a
ty = case Type a
ty of
                  TLocated Type a
t Range
r1 -> Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r1 Type a
t
                  TUser a
n [Type a]
ts -> Range -> Located a -> [Type a] -> Maybe (Located a, [Located a])
forall {a} {a}.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n } [Type a]
ts
                  TInfix Type a
t1 Located a
n Fixity
_ Type a
t2  -> Range -> Located a -> [Type a] -> Maybe (Located a, [Located a])
forall {a} {a}.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r Located a
n [Type a
t1,Type a
t2]
                  Type a
_ -> Maybe (Located a, [Located a])
forall a. Maybe a
Nothing

  mkT :: Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r a
n [Type a]
ts = do [Located a]
ts1 <- (Type a -> Maybe (Located a)) -> [Type a] -> Maybe [Located a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Range -> Type a -> Maybe (Located a)
forall {a}. Range -> Type a -> Maybe (Located a)
isVar Range
r) [Type a]
ts
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([a] -> Bool
forall {a}. Eq a => [a] -> Bool
distinct ((Located a -> a) -> [Located a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Located a -> a
forall a. Located a -> a
thing [Located a]
ts1))
                  (a, [Located a]) -> Maybe (a, [Located a])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n,[Located a]
ts1)

  isVar :: Range -> Type a -> Maybe (Located a)
isVar Range
r Type a
ty = case Type a
ty of
                 TLocated Type a
t Range
r1  -> Range -> Type a -> Maybe (Located a)
isVar Range
r1 Type a
t
                 TUser a
n []     -> Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n }
                 Type a
_              -> Maybe (Located a)
forall a. Maybe a
Nothing

  -- inefficient, but the lists should be small
  distinct :: [a] -> Bool
distinct [a]
xs = case [a]
xs of
                  [] -> Bool
True
                  a
x : [a]
ys -> Bool -> Bool
not (a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ys) Bool -> Bool -> Bool
&& [a] -> Bool
distinct [a]
ys

  tpK :: TParam n -> ParseM (n, (TParam n, Kind))
tpK TParam n
tp = case TParam n -> Maybe Kind
forall n. TParam n -> Maybe Kind
tpKind TParam n
tp of
             Just Kind
k  -> (n, (TParam n, Kind)) -> ParseM (n, (TParam n, Kind))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam n -> n
forall n. TParam n -> n
tpName TParam n
tp, (TParam n
tp,Kind
k))
             Maybe Kind
Nothing ->
              case TParam n -> Maybe Range
forall n. TParam n -> Maybe Range
tpRange TParam n
tp of
                Just Range
r -> Range -> [[Char]] -> ParseM (n, (TParam n, Kind))
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]
"Parameters need a kind annotation"]
                Maybe Range
Nothing -> [Char] -> [[Char]] -> ParseM (n, (TParam n, Kind))
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"mkPrimTypeDecl"
                              [ [Char]
"Missing range on schema parameter." ]


-- | Fix-up the documentation strings by removing the comment delimiters on each
-- end, and stripping out common prefixes on all the remaining lines.
mkDoc :: Located Text -> Located Text
mkDoc :: Located Text -> Located Text
mkDoc Located Text
ltxt = Located Text
ltxt { thing = docStr }
  where

  docStr :: Text
docStr = [Text] -> Text
T.unlines
         ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
dropPrefix
         ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
trimFront
         ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines
         (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
commentChar
         (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Located Text -> Text
forall a. Located a -> a
thing Located Text
ltxt

  commentChar :: Char -> Bool
  commentChar :: Char -> Bool
commentChar Char
x = Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"/* \r\n\t" :: String)

  prefixDroppable :: Char -> Bool
prefixDroppable Char
x = Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"* \r\n\t" :: String)

  whitespaceChar :: Char -> Bool
  whitespaceChar :: Char -> Bool
whitespaceChar Char
x = Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
" \r\n\t" :: String)

  trimFront :: [Text] -> [Text]
trimFront []                     = []
  trimFront (Text
l:[Text]
ls)
    | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
commentChar Text
l = [Text]
ls
    | Bool
otherwise           = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ls

  dropPrefix :: [Text] -> [Text]
dropPrefix []        = []
  dropPrefix [Text
t]       = [(Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
t]
  dropPrefix ts :: [Text]
ts@(Text
l:[Text]
ls) =
    case Text -> Maybe (Char, Text)
T.uncons Text
l of
      Just (Char
c,Text
_) | Char -> Bool
prefixDroppable Char
c Bool -> Bool -> Bool
&&
                   (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Text -> Bool
commonPrefix Char
c) [Text]
ls -> [Text] -> [Text]
dropPrefix ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
T.drop Int
1) [Text]
ts)
      Maybe (Char, Text)
_                                    -> [Text]
ts

    where
    commonPrefix :: Char -> Text -> Bool
commonPrefix Char
c Text
t =
      case Text -> Maybe (Char, Text)
T.uncons Text
t of
        Just (Char
c',Text
_) -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'
        Maybe (Char, Text)
Nothing     -> Char -> Bool
whitespaceChar Char
c -- end-of-line matches any whitespace


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 <- Located [a] -> [a]
forall a. Located a -> a
thing Located [a]
x ]
  where r :: Range
r = Located [a] -> Range
forall a. Located a -> Range
srcRange Located [a]
x

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
     [Located (Prop PName)] -> ParseM [Located (Prop PName)]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located [Prop PName]
lp { thing = p } | Prop PName
p <- Located [Prop PName] -> [Prop PName]
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 -> Range -> [Prop PName] -> Located [Prop PName]
forall a. Range -> a -> Located a
Located Range
r ([Prop PName] -> Located [Prop PName])
-> ParseM [Prop PName] -> ParseM (Located [Prop PName])
forall a b. (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Range -> Type PName -> ParseM [Prop PName]
forall {n}. Range -> Type n -> ParseM [Prop n]
props Range
r Type PName
t
    Type PName
_            -> [Char] -> [[Char]] -> ParseM (Located [Prop PName])
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"Parser" [ [Char]
"Invalid type given to mkProp"
                                   , [Char]
"expected a location"
                                   , Type PName -> [Char]
forall a. Show a => a -> [Char]
show Type PName
ty ]

  where

  props :: Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t =
    case Type n
t of
      TInfix{}       -> [Prop n] -> ParseM [Prop n]
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type n -> Prop n
forall n. Type n -> Prop n
CType Type n
t]
      TUser{}        -> [Prop n] -> ParseM [Prop n]
forall a. a -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type n -> Prop n
forall n. Type n -> Prop n
CType Type n
t]
      TTuple [Type n]
ts      -> [[Prop n]] -> [Prop n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Prop n]] -> [Prop n]) -> ParseM [[Prop n]] -> ParseM [Prop n]
forall a b. (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Type n -> ParseM [Prop n]) -> [Type n] -> ParseM [[Prop n]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
_  -> ParseM [Prop n]
forall a. ParseM a
err

      TLocated Type n
t' Range
r' -> Range -> Type n -> ParseM [Prop n]
props Range
r' Type n
t'

      TFun{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TSeq{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TBit{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TNum{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TChar{}   -> ParseM [Prop n]
forall a. ParseM a
err
      Type n
TWild     -> ParseM [Prop n]
forall a. ParseM a
err
      TRecord{} -> ParseM [Prop n]
forall a. ParseM a
err
      TTyApp{}  -> ParseM [Prop n]
forall a. ParseM a
err

    where
    err :: ParseM a
err = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r [[Char]
"Invalid constraint"]

-- | Make an ordinary module
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 = [TopDecl PName] -> ModuleDefinition PName
forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
ds
                        , mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty
                        }

mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested Module PName
m =
  case ModName -> [[Char]]
modNameChunks (Located ModName -> ModName
forall a. Located a -> a
thing Located ModName
nm) of
    [[Char]
c] -> NestedModule PName -> ParseM (NestedModule PName)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleG PName PName -> NestedModule PName
forall name. ModuleG name name -> NestedModule name
NestedModule Module PName
m { mName = nm { thing = mkUnqual (packIdent c)}})
    [[Char]]
_   -> Range -> [[Char]] -> ParseM (NestedModule PName)
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
r
                [[Char]
"Nested modules names should be a simple identifier."]
  where
  nm :: Located ModName
nm = Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
mName Module PName
m
  r :: Range
r = Located ModName -> Range
forall a. Located a -> Range
srcRange Located ModName
nm

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) =
  TopLevel (NestedModule PName) -> TopDecl PName
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  = ModuleG PName PName -> NestedModule PName
forall name. ModuleG name name -> NestedModule name
NestedModule
                        Module { mName :: LPName
mName    = LPName
nm
                               , mDef :: ModuleDefinition PName
mDef     = Signature PName -> ModuleDefinition PName
forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
                               , mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty
                               }
           }

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
     [TopDecl PName] -> ParseM [TopDecl PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Text -> Located [Prop PName] -> TopDecl PName
forall name. Maybe Text -> Located [Prop name] -> TopDecl name
DInterfaceConstraint (Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc) Located [Prop PName]
ps]

mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls [ParamDecl PName]
ds = Range -> Signature PName -> TopDecl PName
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 ((ParamDecl PName -> Maybe Range) -> [ParamDecl PName] -> [Range]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ParamDecl PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc [ParamDecl PName]
ds)

onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports = (Located (ImportG (ImpName PName)) -> ParseM ())
-> [Located (ImportG (ImpName PName))] -> ParseM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Located (ImportG (ImpName PName)) -> ParseM ()
forall {mname}. Located (ImportG mname) -> ParseM ()
check
  where
  check :: Located (ImportG mname) -> ParseM ()
check Located (ImportG mname)
i =
    case ImportG mname -> Maybe (ModuleInstanceArgs PName)
forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (Located (ImportG mname) -> ImportG mname
forall a. Located a -> a
thing Located (ImportG mname)
i) of
      Maybe (ModuleInstanceArgs PName)
Nothing -> () -> ParseM ()
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ModuleInstanceArgs PName
_  ->
        Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Located (ImportG mname) -> Range
forall a. Located a -> Range
srcRange Located (ImportG mname)
i)
          [ [Char]
"Functor instantiations are not supported in this context."
          , [Char]
"The imported entity needs to be just the name of a module."
          , [Char]
"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 =
  (Signature PName -> ParamDecl PName -> Signature PName)
-> Signature PName -> [ParamDecl PName] -> Signature PName
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Signature PName -> ParamDecl PName -> Signature PName
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  = pt  : sigTypeParams s  }
      DParameterConstraint [Located (Prop name)]
ps -> Signature name
s { sigConstraints = ps ++ sigConstraints s }
      DParameterDecl SigDecl name
pd       -> Signature name
s { sigDecls       = pd  : sigDecls s       }
      DParameterFun ParameterFun name
pf        -> Signature name
s { sigFunParams   = pf  : sigFunParams 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
     Signature PName -> ParseM (Signature PName)
forall a. a -> ParseM a
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    -> SigDecl PName -> ParamDecl PName
forall name. SigDecl name -> ParamDecl name
DParameterDecl (TySyn PName -> Maybe Text -> SigDecl PName
forall name. TySyn name -> Maybe Text -> SigDecl name
SigTySyn TySyn PName
ts Maybe Text
mbDoc)
    DProp PropSyn PName
ps    -> SigDecl PName -> ParamDecl PName
forall name. SigDecl name -> ParamDecl name
DParameterDecl (PropSyn PName -> Maybe Text -> SigDecl PName
forall name. PropSyn name -> Maybe Text -> SigDecl name
SigPropSyn PropSyn PName
ps Maybe Text
mbDoc)
    Decl PName
_ -> [Char] -> [[Char]] -> ParamDecl PName
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"mkIfacePropSyn" [ [Char]
"Unexpected declaration", Doc -> [Char]
forall a. Show a => a -> [Char]
show (Decl PName -> Doc
forall a. PP a => a -> Doc
pp Decl PName
d) ]


-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule = Module PName -> ParseM [Module PName]
mkTopMods
                  (Module PName -> ParseM [Module PName])
-> ([TopDecl PName] -> Module PName)
-> [TopDecl PName]
-> ParseM [Module PName]
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 [[Char] -> Text
T.pack [Char]
"Main"]
                                     }

-- | Make a module which defines a functor instance.
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     = Located (ImpName PName)
-> ModuleInstanceArgs PName
-> ModuleInstance PName
-> ModuleDefinition PName
forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
fun ([TopDecl PName] -> ModuleInstanceArgs PName
forall name. [TopDecl name] -> ModuleInstanceArgs name
DefaultInstAnonArg [TopDecl PName]
ds) ModuleInstance PName
forall a. Monoid a => a
mempty
         , mInScope :: NamingEnv
mInScope = NamingEnv
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     = Located (ImpName PName)
-> ModuleInstanceArgs PName
-> ModuleInstance PName
-> ModuleDefinition PName
forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
forall name. Ord name => ModuleInstance name
emptyModuleInstance
         , mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty
         }


ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField UpdHow
h [Located Selector]
ls Expr PName
e) =
  case (UpdHow
h,[Located Selector]
ls) of
    (UpdHow
UpdSet, [Located Selector
l]) | RecordSel Ident
i Maybe [Ident]
Nothing <- Located Selector -> Selector
forall a. Located a -> a
thing Located Selector
l ->
      Named (Expr PName) -> ParseM (Named (Expr PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Named { name :: Located Ident
name = Located Selector
l { thing = i }, value :: Expr PName
value = Expr PName
e }
    (UpdHow, [Located Selector])
_ -> Range -> [[Char]] -> ParseM (Named (Expr PName))
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Located Selector -> Range
forall a. Located a -> Range
srcRange ([Located Selector] -> Located Selector
forall a. HasCallStack => [a] -> a
head [Located Selector]
ls))
            [[Char]
"Invalid record field.  Perhaps you meant to update a record?"]

exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath Expr PName
e0 = [Located Selector] -> [Located Selector]
forall a. [a] -> [a]
reverse ([Located Selector] -> [Located Selector])
-> ParseM [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM [Located Selector]
go Range
forall {a}. a
noLoc Expr PName
e0
  where
  noLoc :: a
noLoc = [Char] -> [[Char]] -> a
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"selExprToSels" [[Char]
"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 = to (srcRange (head ls)) }
           [Located Selector] -> ParseM [Located Selector]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located { thing :: Selector
thing = Selector
s, srcRange :: Range
srcRange = Range
rng } Located Selector -> [Located Selector] -> [Located Selector]
forall a. a -> [a] -> [a]
: [Located Selector]
ls)
      EVar (UnQual Ident
l) ->
        [Located Selector] -> ParseM [Located Selector]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing = Ident -> Maybe [Ident] -> Selector
RecordSel Ident
l Maybe [Ident]
forall a. Maybe a
Nothing, srcRange :: Range
srcRange = Range
loc } ]

      ELit (ECNum Integer
n (DecLit {})) ->
        [Located Selector] -> ParseM [Located Selector]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) Maybe Int
forall a. Maybe a
Nothing
                       , srcRange :: Range
srcRange = Range
loc } ]

      ELit (ECFrac Rational
_ (DecFrac Text
txt))
        | (Text
as,Text
bs') <- (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
txt
        , Just Int
a <- [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
as)
        , Just (Char
_,Text
bs) <- Text -> Maybe (Char, Text)
T.uncons Text
bs'
        , Just Int
b <- [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
bs)
        , let fromP :: Position
fromP = Range -> Position
from Range
loc
        , let midP :: Position
midP  = Position
fromP { col = col fromP + T.length as + 1 } ->
          -- these are backward because we reverse above
          [Located Selector] -> ParseM [Located Selector]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing    = Int -> Maybe Int -> Selector
TupleSel Int
b Maybe Int
forall a. Maybe a
Nothing
                         , srcRange :: Range
srcRange = Range
loc { from = midP }
                         }
               , Located { thing :: Selector
thing    = Int -> Maybe Int -> Selector
TupleSel Int
a Maybe Int
forall a. Maybe a
Nothing
                         , srcRange :: Range
srcRange = Range
loc { to = midP }
                         }
               ]

      Expr PName
_ -> Range -> [[Char]] -> ParseM [Located Selector]
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
loc [[Char]
"Invalid label in record update."]


mkSelector :: Token -> Selector
mkSelector :: Token -> Selector
mkSelector Token
tok =
  case Token -> TokenT
tokenType Token
tok of
    Selector (TupleSelectorTok Int
n) -> Int -> Maybe Int -> Selector
TupleSel Int
n Maybe Int
forall a. Maybe a
Nothing
    Selector (RecordSelectorTok Text
t) -> Ident -> Maybe [Ident] -> Selector
RecordSel (Text -> Ident
mkIdent Text
t) Maybe [Ident]
forall a. Maybe a
Nothing
    TokenT
_ -> [Char] -> [[Char]] -> Selector
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"mkSelector" [ [Char]
"Unexpected selector token", Token -> [Char]
forall a. Show a => a -> [Char]
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 (ModuleInstanceArgs PName -> Maybe (ModuleInstanceArgs PName)
forall a. a -> Maybe a
Just ModuleInstanceArgs PName
forall {name}. ModuleInstanceArgs name
inst) Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec Maybe (Located [Decl PName])
forall a. Maybe a
Nothing
  where
  inst :: ModuleInstanceArgs name
inst = Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
forall name.
Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
DefaultInstArg ((ImpName PName -> ModuleInstanceArg name)
-> Located (ImpName PName) -> Located (ModuleInstanceArg name)
forall a b. (a -> b) -> Located a -> Located b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleInstanceArg name -> ImpName PName -> ModuleInstanceArg name
forall a b. a -> b -> a
const ModuleInstanceArg name
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 = Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe (Located (ImpName PName) -> Range
forall a. Located a -> Range
srcRange Located (ImpName PName)
impName)
             (Maybe Range -> Range) -> Maybe Range -> Range
forall a b. (a -> b) -> a -> b
$ [Maybe Range] -> Maybe Range
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ Located [Decl PName] -> Range
forall a. Located a -> Range
srcRange (Located [Decl PName] -> Range)
-> Maybe (Located [Decl PName]) -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located [Decl PName])
optImportWhere
                    , Located ImportSpec -> Range
forall a. Located a -> Range
srcRange (Located ImportSpec -> Range)
-> Maybe (Located ImportSpec) -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ImportSpec)
mbImportSpec
                    , Located ModName -> Range
forall a. Located a -> Range
srcRange (Located ModName -> Range)
-> Maybe (Located ModName) -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ModName)
mbAs
                    ]

     Located (ImportG (ImpName PName))
-> ParseM (Located (ImportG (ImpName PName)))
forall a. a -> ParseM a
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    = Located (ImpName PName) -> ImpName PName
forall a. Located a -> a
thing Located (ImpName PName)
impName
                                 , iAs :: Maybe ModName
iAs        = Located ModName -> ModName
forall a. Located a -> a
thing (Located ModName -> ModName)
-> Maybe (Located ModName) -> Maybe ModName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ModName)
mbAs
                                 , iSpec :: Maybe ImportSpec
iSpec      = Located ImportSpec -> ImportSpec
forall a. Located a -> a
thing (Located ImportSpec -> ImportSpec)
-> Maybe (Located ImportSpec) -> Maybe ImportSpec
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]
_) ->
         Range -> [[Char]] -> ParseM (Maybe (ModuleInstanceArgs PName))
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
loc [ [Char]
"Invalid instantiating import."
                          , [Char]
"Import should have at most one of:"
                          , [Char]
"  * { } instantiation, or"
                          , [Char]
"  * where instantiation"
                          ]
      (Just ModuleInstanceArgs PName
a, Maybe (Located [Decl PName])
Nothing)  -> Maybe (ModuleInstanceArgs PName)
-> ParseM (Maybe (ModuleInstanceArgs PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleInstanceArgs PName -> Maybe (ModuleInstanceArgs PName)
forall a. a -> Maybe a
Just ModuleInstanceArgs PName
a)
      (Maybe (ModuleInstanceArgs PName)
Nothing, Just Located [Decl PName]
a)  ->
        Maybe (ModuleInstanceArgs PName)
-> ParseM (Maybe (ModuleInstanceArgs PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleInstanceArgs PName -> Maybe (ModuleInstanceArgs PName)
forall a. a -> Maybe a
Just ([TopDecl PName] -> ModuleInstanceArgs PName
forall name. [TopDecl name] -> ModuleInstanceArgs name
DefaultInstAnonArg ((Decl PName -> TopDecl PName) -> [Decl PName] -> [TopDecl PName]
forall a b. (a -> b) -> [a] -> [b]
map Decl PName -> TopDecl PName
forall {name}. Decl name -> TopDecl name
instTop (Located [Decl PName] -> [Decl PName]
forall a. Located a -> a
thing Located [Decl PName]
a))))
         where
         instTop :: Decl name -> TopDecl name
instTop Decl name
d = TopLevel (Decl name) -> TopDecl name
forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel
                            { tlExport :: ExportType
tlExport = ExportType
Public
                            , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
forall a. Maybe a
Nothing
                            , tlValue :: Decl name
tlValue  = Decl name
d
                            }
      (Maybe (ModuleInstanceArgs PName)
Nothing, Maybe (Located [Decl PName])
Nothing) -> Maybe (ModuleInstanceArgs PName)
-> ParseM (Maybe (ModuleInstanceArgs PName))
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ModuleInstanceArgs PName)
forall a. Maybe a
Nothing





mkTopMods :: Module PName -> ParseM [Module PName]
mkTopMods :: Module PName -> ParseM [Module PName]
mkTopMods = Module PName -> ParseM [Module PName]
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     = Signature PName -> ModuleDefinition PName
forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
           , mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty
           }
  ]


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     = ModName -> ImpName PName
forall name. ModName -> ImpName name
ImpTop

instance MkAnon PName where
  mkAnon :: AnonThing -> PName -> PName
mkAnon AnonThing
what   = Ident -> PName
mkUnqual
                (Ident -> PName) -> (PName -> Ident) -> PName -> PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case AnonThing
what of
                    AnonThing
AnonArg      -> Ident -> Ident
identAnonArg
                    AnonThing
AnonIfaceMod -> Ident -> Ident
identAnonIfaceMod
                (Ident -> Ident) -> (PName -> Ident) -> PName -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PName -> Ident
getIdent
  toImpName :: PName -> ImpName PName
toImpName     = PName -> ImpName PName
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 ModuleG name PName -> ModuleDefinition PName
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') <- Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs (ModuleG name PName -> Located name
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 <- ModuleG name PName -> ModuleDefinition PName
forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG name PName
m
                 , Range
l : [Range]
_ <- (ParameterType PName -> Range) -> [ParameterType PName] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map (LPName -> Range
forall a. Located a -> Range
srcRange (LPName -> Range)
-> (ParameterType PName -> LPName) -> ParameterType PName -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParameterType PName -> LPName
forall name. ParameterType name -> Located name
ptName) (Signature PName -> [ParameterType PName]
forall name. Signature name -> [ParameterType name]
sigTypeParams Signature PName
si) [Range] -> [Range] -> [Range]
forall a. [a] -> [a] -> [a]
++
                            (ParameterFun PName -> Range) -> [ParameterFun PName] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map (LPName -> Range
forall a. Located a -> Range
srcRange (LPName -> Range)
-> (ParameterFun PName -> LPName) -> ParameterFun PName -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParameterFun PName -> LPName
forall name. ParameterFun name -> Located name
pfName) (Signature PName -> [ParameterFun PName]
forall name. Signature name -> [ParameterFun name]
sigFunParams Signature PName
si) [Range] -> [Range] -> [Range]
forall a. [a] -> [a] -> [a]
++
                            [ Located name -> Range
forall a. Located a -> Range
srcRange (ModuleG name PName -> Located name
forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) ] ->
              Range -> [[Char]] -> ParseM ()
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
l
                [ [Char]
"Instantiation of a parameterized module may not itself be "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"parameterized" ]
           [ModuleG name PName]
_ -> () -> ParseM ()
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         let i :: name
i      = AnonThing -> name -> name
forall t. MkAnon t => AnonThing -> t -> t
mkAnon AnonThing
AnonArg (Located name -> name
forall a. Located a -> a
thing (ModuleG name PName -> Located name
forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo))
             nm :: Located name
nm     = Located { srcRange :: Range
srcRange = Located name -> Range
forall a. Located a -> Range
srcRange (ModuleG name PName -> Located name
forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo), thing :: name
thing = name
i }
             as' :: ModuleInstanceArgs PName
as'    = Located (ModuleInstanceArg PName) -> ModuleInstanceArgs PName
forall name.
Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
DefaultInstArg (ImpName PName -> ModuleInstanceArg PName
forall name. ImpName name -> ModuleInstanceArg name
ModuleArg (ImpName PName -> ModuleInstanceArg PName)
-> (name -> ImpName PName) -> name -> ModuleInstanceArg PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name -> ImpName PName
forall t. MkAnon t => t -> ImpName PName
toImpName (name -> ModuleInstanceArg PName)
-> Located name -> Located (ModuleInstanceArg PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm)
         [ModuleG name PName] -> ParseM [ModuleG name PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Module
                  { mName :: Located name
mName = Located name
nm, mDef :: ModuleDefinition PName
mDef  = [TopDecl PName] -> ModuleDefinition PName
forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
lds', mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty }
              , ModuleG name PName
mo { mDef = FunctorInstance f as' mempty }
              ]

    NormalModule [TopDecl PName]
ds ->
      do ([ModuleG name PName]
newMs, [TopDecl PName]
newDs) <- Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs (ModuleG name PName -> Located name
forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) [TopDecl PName]
ds
         [ModuleG name PName] -> ParseM [ModuleG name PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleG name PName]
newMs [ModuleG name PName]
-> [ModuleG name PName] -> [ModuleG name PName]
forall a. [a] -> [a] -> [a]
++ [ ModuleG name PName
mo { mDef = NormalModule newDs } ])

    ModuleDefinition PName
_ -> [ModuleG name PName] -> ParseM [ModuleG name PName]
forall a. a -> ParseM a
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 Signature PName
forall {name}. Signature name
emptySig
  where
  isEmpty :: Signature name -> Bool
isEmpty Signature name
s =
    [ParameterType name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Signature name -> [ParameterType name]
forall name. Signature name -> [ParameterType name]
sigTypeParams Signature name
s) Bool -> Bool -> Bool
&& [Located (Prop name)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Signature name -> [Located (Prop name)]
forall name. Signature name -> [Located (Prop name)]
sigConstraints Signature name
s) Bool -> Bool -> Bool
&& [ParameterFun name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Signature name -> [ParameterFun name]
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      = (Signature name -> [Located (ImportG (ImpName name))])
-> [Located (ImportG (ImpName name))]
forall {a}. (Signature name -> [a]) -> [a]
j Signature name -> [Located (ImportG (ImpName name))]
forall name. Signature name -> [Located (ImportG (ImpName name))]
sigImports
                          , sigTypeParams :: [ParameterType name]
sigTypeParams   = (Signature name -> [ParameterType name]) -> [ParameterType name]
forall {a}. (Signature name -> [a]) -> [a]
j Signature name -> [ParameterType name]
forall name. Signature name -> [ParameterType name]
sigTypeParams
                          , sigDecls :: [SigDecl name]
sigDecls        = (Signature name -> [SigDecl name]) -> [SigDecl name]
forall {a}. (Signature name -> [a]) -> [a]
j Signature name -> [SigDecl name]
forall name. Signature name -> [SigDecl name]
sigDecls
                          , sigConstraints :: [Located (Prop name)]
sigConstraints  = (Signature name -> [Located (Prop name)]) -> [Located (Prop name)]
forall {a}. (Signature name -> [a]) -> [a]
j Signature name -> [Located (Prop name)]
forall name. Signature name -> [Located (Prop name)]
sigConstraints
                          , sigFunParams :: [ParameterFun name]
sigFunParams    = (Signature name -> [ParameterFun name]) -> [ParameterFun name]
forall {a}. (Signature name -> [a]) -> [a]
j Signature name -> [ParameterFun name]
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 [a] -> [a] -> [a]
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 = i : sigImports s }

  go :: Signature PName
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
go Signature PName
sig [TopDecl PName]
ds =
    case [TopDecl PName]
ds of

      []
        | Signature PName -> Bool
forall {name}. Signature name -> Bool
isEmpty Signature PName
sig -> ([ModuleG name PName], [TopDecl PName])
-> ParseM ([ModuleG name PName], [TopDecl PName])
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([],[])
        | Bool
otherwise ->
          do let nm :: Located name
nm = AnonThing -> name -> name
forall t. MkAnon t => AnonThing -> t -> t
mkAnon AnonThing
AnonIfaceMod (name -> name) -> Located name -> Located name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
ownerName
             ([ModuleG name PName], [TopDecl PName])
-> ParseM ([ModuleG name PName], [TopDecl PName])
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [ Module { mName :: Located name
mName = Located name
nm
                             , mDef :: ModuleDefinition PName
mDef = Signature PName -> ModuleDefinition PName
forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
                             , mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty
                             }
                     ]
                  , [ ModParam PName -> TopDecl PName
forall name. ModParam name -> TopDecl name
DModParam
                      ModParam
                        { mpSignature :: Located (ImpName PName)
mpSignature = name -> ImpName PName
forall t. MkAnon t => t -> ImpName PName
toImpName (name -> ImpName PName) -> Located name -> Located (ImpName PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm
                        , mpAs :: Maybe ModName
mpAs        = Maybe ModName
forall a. Maybe a
Nothing
                        , mpName :: Ident
mpName      = Located (ImpName PName) -> Maybe (Located ModName) -> Ident
mkModParamName (name -> ImpName PName
forall t. MkAnon t => t -> ImpName PName
toImpName (name -> ImpName PName) -> Located name -> Located (ImpName PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm)
                                                                        Maybe (Located ModName)
forall a. Maybe a
Nothing
                        , mpDoc :: Maybe (Located Text)
mpDoc       = Maybe (Located Text)
forall a. Maybe a
Nothing
                        , mpRenaming :: ModuleInstance PName
mpRenaming  = ModuleInstance PName
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
                 ([ModuleG name PName], [TopDecl PName])
-> ParseM ([ModuleG name PName], [TopDecl PName])
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleG name PName]
ms, [TopDecl PName]
emit [TopDecl PName] -> [TopDecl PName] -> [TopDecl PName]
forall a. [a] -> [a] -> [a]
++ [TopDecl PName]
ds')
        in
        case TopDecl PName
d of

          DImport Located (ImportG (ImpName PName))
i | ImpTop ModName
_ <- ImportG (ImpName PName) -> ImpName PName
forall mname. ImportG mname -> mname
iModule (Located (ImportG (ImpName PName)) -> ImportG (ImpName PName)
forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i)
                    , Maybe (ModuleInstanceArgs PName)
Nothing  <- ImportG (ImpName PName) -> Maybe (ModuleInstanceArgs PName)
forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (Located (ImportG (ImpName PName)) -> ImportG (ImpName PName)
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] (Located (ImportG (ImpName PName))
-> Signature PName -> Signature PName
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 <- ImportG (ImpName PName) -> Maybe (ModuleInstanceArgs PName)
forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (Located (ImportG (ImpName PName)) -> ImportG (ImpName PName)
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 [] (Signature PName -> Signature PName -> Signature PName
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 <- TopLevel (NestedModule PName) -> NestedModule PName
forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
tl ->
            do [ModuleG PName PName]
ms <- ModuleG PName PName -> ParseM [ModuleG PName PName]
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 [ TopLevel (NestedModule PName) -> TopDecl PName
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
tl { tlValue = NestedModule 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)) {- ^ The import -} ->
  ModuleInstanceArgs PName          {- ^ The insantiation -} ->
  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 <- ModuleG PName PName -> ParseM [ModuleG PName PName]
forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod
           Module { mName :: LPName
mName    = Located (ImportG (ImpName PName))
i { thing = iname }
                  , mDef :: ModuleDefinition PName
mDef     = Located (ImpName PName)
-> ModuleInstanceArgs PName
-> ModuleInstance PName
-> ModuleDefinition PName
forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance
                                 (ImportG (ImpName PName) -> ImpName PName
forall mname. ImportG mname -> mname
iModule (ImportG (ImpName PName) -> ImpName PName)
-> Located (ImportG (ImpName PName)) -> Located (ImpName PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (ImportG (ImpName PName))
i) ModuleInstanceArgs PName
inst ModuleInstance PName
forall name. Ord name => ModuleInstance name
emptyModuleInstance
                  , mInScope :: NamingEnv
mInScope = NamingEnv
forall a. Monoid a => a
mempty
                  }
     [TopDecl PName] -> ParseM [TopDecl PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (ImportG (ImpName PName)) -> TopDecl PName
forall name. Located (ImportG (ImpName name)) -> TopDecl name
DImport (ImportG (ImpName PName) -> ImportG (ImpName PName)
forall {mname}. ImportG mname -> ImportG (ImpName PName)
newImp (ImportG (ImpName PName) -> ImportG (ImpName PName))
-> Located (ImportG (ImpName PName))
-> Located (ImportG (ImpName PName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (ImportG (ImpName PName))
i) TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
: (ModuleG PName PName -> TopDecl PName)
-> [ModuleG PName PName] -> [TopDecl PName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleG PName PName -> TopDecl PName
forall {name}. ModuleG name name -> TopDecl name
modTop [ModuleG PName PName]
ms)

  where
  imp :: ImportG (ImpName PName)
imp = Located (ImportG (ImpName PName)) -> ImportG (ImpName PName)
forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i
  iname :: PName
iname = Ident -> PName
mkUnqual
        (Ident -> PName) -> Ident -> PName
forall a b. (a -> b) -> a -> b
$ Text -> Ident
mkIdent
        (Text -> Ident) -> Text -> Ident
forall a b. (a -> b) -> a -> b
$ Text
"import of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (Doc -> [Char]
forall a. Show a => a -> [Char]
show (Range -> Doc
forall a. PP a => a -> Doc
pp (Located (ImportG (ImpName PName)) -> Range
forall a. Located a -> Range
srcRange Located (ImportG (ImpName PName))
i)))
    where
    nm :: Text
nm = case ImportG (ImpName PName) -> ImpName PName
forall mname. ImportG mname -> mname
iModule ImportG (ImpName PName)
imp of
           ImpTop ModName
f    -> ModName -> Text
modNameToText ModName
f
           ImpNested PName
n -> Text
"submodule " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (Doc -> [Char]
forall a. Show a => a -> [Char]
show (PName -> Doc
forall a. PP a => a -> Doc
pp PName
n))

  newImp :: ImportG mname -> ImportG (ImpName PName)
newImp ImportG mname
d = ImportG mname
d { iModule = ImpNested iname
               , iInst   = Nothing
               }

  modTop :: ModuleG name name -> TopDecl name
modTop ModuleG name name
m = TopLevel (NestedModule name) -> TopDecl name
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel
                       { tlExport :: ExportType
tlExport = ExportType
Private
                       , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
forall a. Maybe a
Nothing
                       , tlValue :: NestedModule name
tlValue  = ModuleG name name -> NestedModule name
forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG name name
m
                       }