-- |
-- 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 #-}
{-# LANGUAGE LambdaCase #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where

import Data.Char(isAlphaNum, isSpace)
import Data.Maybe(fromMaybe, mapMaybe)
import Data.Bits(testBit,setBit)
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 Data.Foldable (for_)

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, identAnonInstImport
                          , modNameArg, modNameIfaceMod
                          , mainModName, 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) }

askConfig :: ParseM Config
askConfig :: ParseM Config
askConfig = (Config -> Position -> S -> Either ParseError (Config, S))
-> ParseM Config
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P \Config
cfg Position
_ S
s -> (Config, S) -> Either ParseError (Config, S)
forall a b. b -> Either a b
Right (Config
cfg, S
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 (Located Text)
pfDoc = 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 (Located Text)
ptDoc     = 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

addDeclDocstring :: Located Text -> TopDecl name -> ParseM (TopDecl name)
addDeclDocstring :: forall name. Located Text -> TopDecl name -> ParseM (TopDecl name)
addDeclDocstring Located Text
doc 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) -> TopDecl name)
-> ParseM (TopLevel (Decl name)) -> ParseM (TopDecl name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (Decl name) -> ParseM (TopLevel (Decl name))
forall {a}. TopLevel a -> ParseM (TopLevel a)
topLevel TopLevel (Decl name)
d
    DPrimType TopLevel (PrimType name)
t -> TopLevel (PrimType name) -> TopDecl name
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType (TopLevel (PrimType name) -> TopDecl name)
-> ParseM (TopLevel (PrimType name)) -> ParseM (TopDecl name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (PrimType name) -> ParseM (TopLevel (PrimType name))
forall {a}. TopLevel a -> ParseM (TopLevel a)
topLevel TopLevel (PrimType name)
t
    TDNewtype TopLevel (Newtype name)
n -> TopLevel (Newtype name) -> TopDecl name
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype (TopLevel (Newtype name) -> TopDecl name)
-> ParseM (TopLevel (Newtype name)) -> ParseM (TopDecl name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (Newtype name) -> ParseM (TopLevel (Newtype name))
forall {a}. TopLevel a -> ParseM (TopLevel a)
topLevel TopLevel (Newtype name)
n
    TDEnum TopLevel (EnumDecl name)
n -> TopLevel (EnumDecl name) -> TopDecl name
forall name. TopLevel (EnumDecl name) -> TopDecl name
TDEnum (TopLevel (EnumDecl name) -> TopDecl name)
-> ParseM (TopLevel (EnumDecl name)) -> ParseM (TopDecl name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (EnumDecl name) -> ParseM (TopLevel (EnumDecl name))
forall {a}. TopLevel a -> ParseM (TopLevel a)
topLevel TopLevel (EnumDecl name)
n
    DModule TopLevel (NestedModule name)
m -> TopLevel (NestedModule name) -> TopDecl name
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule (TopLevel (NestedModule name) -> TopDecl name)
-> ParseM (TopLevel (NestedModule name)) -> ParseM (TopDecl name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (NestedModule name)
-> ParseM (TopLevel (NestedModule name))
forall {a}. TopLevel a -> ParseM (TopLevel a)
topLevel TopLevel (NestedModule name)
m
    DModParam ModParam name
p -> TopDecl name -> ParseM (TopDecl name)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModParam name -> TopDecl name
forall name. ModParam name -> TopDecl name
DModParam ModParam name
p { mpDoc = Just doc })
    Include Located [Char]
_ -> [Char] -> ParseM (TopDecl name)
forall a. [Char] -> ParseM a
failure [Char]
"Docstring on include"
    DImport Located (ImportG (ImpName name))
i -> Located (ImportG (ImpName name)) -> TopDecl name
forall name. Located (ImportG (ImpName name)) -> TopDecl name
DImport (Located (ImportG (ImpName name)) -> TopDecl name)
-> ParseM (Located (ImportG (ImpName name)))
-> ParseM (TopDecl name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ImportG (ImpName name) -> ParseM (ImportG (ImpName name)))
-> Located (ImportG (ImpName name))
-> ParseM (Located (ImportG (ImpName name)))
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) -> Located a -> f (Located b)
traverse ImportG (ImpName name) -> ParseM (ImportG (ImpName name))
forall {mname}. ImportG mname -> ParseM (ImportG mname)
imp Located (ImportG (ImpName name))
i
    DInterfaceConstraint Maybe (Located Text)
Nothing Located [Prop name]
x -> TopDecl name -> ParseM (TopDecl name)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Located Text) -> Located [Prop name] -> TopDecl name
forall name.
Maybe (Located Text) -> Located [Prop name] -> TopDecl name
DInterfaceConstraint (Located Text -> Maybe (Located Text)
forall a. a -> Maybe a
Just Located Text
doc) Located [Prop name]
x)
    DInterfaceConstraint Just{} Located [Prop name]
_ -> [Char] -> ParseM (TopDecl name)
forall a. [Char] -> ParseM a
failure [Char]
"Overlapping docstring"
    DParamDecl{} -> [Char] -> ParseM (TopDecl name)
forall a. [Char] -> ParseM a
failure [Char]
"Docstring on parameter declarations"
  where
    failure :: [Char] -> ParseM a
failure [Char]
e = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
emptyRange (TopDecl name -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc TopDecl name
decl)) [[Char]
e]
    imp :: ImportG mname -> ParseM (ImportG mname)
imp ImportG mname
i =
      case ImportG mname -> Maybe (Located Text)
forall mname. ImportG mname -> Maybe (Located Text)
iDoc ImportG mname
i of
        Maybe (Located Text)
Nothing -> ImportG mname -> ParseM (ImportG mname)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImportG mname
i { iDoc = Just doc }
        Just{}  -> [Char] -> ParseM (ImportG mname)
forall a. [Char] -> ParseM a
failure [Char]
"Overlapping docstring"
    topLevel :: TopLevel a -> ParseM (TopLevel a)
topLevel TopLevel a
x =
      case TopLevel a -> Maybe (Located Text)
forall a. TopLevel a -> Maybe (Located Text)
tlDoc TopLevel a
x of
        Just Located Text
_ -> [Char] -> ParseM (TopLevel a)
forall a. [Char] -> ParseM a
failure [Char]
"Overlapping docstring"
        Maybe (Located Text)
Nothing -> TopLevel a -> ParseM (TopLevel a)
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TopLevel a
x { tlDoc = Just doc }

privateDocedDecl :: Located Text -> [TopDecl PName] -> ParseM [TopDecl PName]
privateDocedDecl :: Located Text -> [TopDecl PName] -> ParseM [TopDecl PName]
privateDocedDecl Located Text
doc (TopDecl PName
decl:[TopDecl PName]
decls) = (TopDecl PName -> [TopDecl PName])
-> ParseM (TopDecl PName) -> ParseM [TopDecl PName]
forall a b. (a -> b) -> ParseM a -> ParseM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
: [TopDecl PName]
decls) (Located Text -> TopDecl PName -> ParseM (TopDecl PName)
forall name. Located Text -> TopDecl name -> ParseM (TopDecl name)
addDeclDocstring Located Text
doc TopDecl PName
decl)
privateDocedDecl Located Text
doc [] = Range -> [[Char]] -> ParseM [TopDecl PName]
forall a. Range -> [[Char]] -> ParseM a
errorMessage (Located Text -> Range
forall a. Located a -> Range
srcRange Located Text
doc) [[Char]
"Docstring on empty private section"]

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 :: BindParams PName
bParams     = [Pattern PName] -> BindParams PName
forall name. [Pattern name] -> BindParams name
PatternParams ([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 (Located Text)
bDoc        = Maybe (Located 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 :: BindParams PName
bParams     = [Pattern PName] -> BindParams PName
forall name. [Pattern name] -> BindParams name
PatternParams ([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 (Located Text)
bDoc        = Maybe (Located 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 :: BindParams PName
bParams     = [Pattern PName] -> BindParams PName
forall name. [Pattern name] -> BindParams name
PatternParams ([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 (Located Text)
bDoc        = Maybe (Located 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 :: BindParams PName
bParams    = BindParams PName
forall name. BindParams name
noParams
                 , 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 (Located Text)
bDoc       = Maybe (Located 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]
handlePrefixes
         ([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]
"/*" :: String) Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
x

  -- Prefix dropping with a special case for the first line and common
  -- prefix dropping for the following lines. The first line and following
  -- lines are treated independently
  handlePrefixes :: [Text] -> [Text]
  handlePrefixes :: [Text] -> [Text]
handlePrefixes [] = []
  handlePrefixes (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'
    where ls' :: [Text]
ls' = [Text] -> [Text]
dropPrefix [Text]
ls

  dropPrefix :: [Text] -> [Text]
  dropPrefix :: [Text] -> [Text]
dropPrefix [Text]
ts =
    case [Text] -> Maybe [Text]
startDropPrefixChar [Text]
ts of
      Maybe [Text]
Nothing -> [Text]
ts -- done dropping
      Just [Text]
ts' -> [Text] -> [Text]
dropPrefix [Text]
ts' -- keep dropping

  -- At the beginning of a prefix stripping operation we check the
  -- first character of the first line. If that first character is
  -- droppable we use it as the prefix to check for, otherwise we
  -- continue searching for whitespace. Return Nothing if there
  -- was no prefix to drop.
  startDropPrefixChar :: [Text] -> Maybe [Text]
  startDropPrefixChar :: [Text] -> Maybe [Text]
startDropPrefixChar [] = Maybe [Text]
forall a. Maybe a
Nothing
  startDropPrefixChar (Text
l:[Text]
ls) =
    case Text -> Maybe (Char, Text)
T.uncons Text
l of
      Maybe (Char, Text)
Nothing -> (Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe [Text]
searchWhitePrefixChar [Text]
ls
      Just (Char
c, Text
l')
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c -> (Text
l'Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> [Text] -> Maybe [Text]
checkPrefixChar Char
c [Text]
ls
        | Bool
otherwise -> Maybe [Text]
forall a. Maybe a
Nothing

  -- So far we've only seen empty lines, so we accept empty
  -- lines and lines starting with whitespace.
  searchWhitePrefixChar :: [Text] -> Maybe [Text]
  searchWhitePrefixChar :: [Text] -> Maybe [Text]
searchWhitePrefixChar [] = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just []
  searchWhitePrefixChar (Text
l:[Text]
ls) =
    case Text -> Maybe (Char, Text)
T.uncons Text
l of
      Maybe (Char, Text)
Nothing -> (Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe [Text]
searchWhitePrefixChar [Text]
ls
      Just (Char
c, Text
l')
        | Char -> Bool
isSpace Char
c -> (Text
l'Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> [Text] -> Maybe [Text]
checkPrefixChar Char
c [Text]
ls
        | Bool
otherwise -> Maybe [Text]
forall a. Maybe a
Nothing

  -- So far we've seen a non-empty line and we know what character
  -- we're looking for. If that character is whitespace then we also
  -- will accept empty lines as matching the prefix
  checkPrefixChar :: Char -> [Text] -> Maybe [Text]
  checkPrefixChar :: Char -> [Text] -> Maybe [Text]
checkPrefixChar Char
_ [] = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just []
  checkPrefixChar Char
p (Text
l:[Text]
ls) =
    case Text -> Maybe (Char, Text)
T.uncons Text
l of
      Maybe (Char, Text)
Nothing
        | Char -> Bool
isSpace Char
p -> (Text
lText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> [Text] -> Maybe [Text]
checkPrefixChar Char
p [Text]
ls
      Just (Char
c,Text
l')
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
p -> (Text
l'Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> [Text] -> Maybe [Text]
checkPrefixChar Char
p [Text]
ls
      Maybe (Char, Text)
_ -> Maybe [Text]
forall a. Maybe a
Nothing

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
                        , mDocTop :: Maybe (Located Text)
mDocTop = Maybe (Located Text)
forall a. Maybe a
Nothing
                        }

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
                               , mDocTop :: Maybe (Located Text)
mDocTop  = Maybe (Located Text)
forall a. Maybe a
Nothing
                               }
           }

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 (Located Text) -> Located [Prop PName] -> TopDecl PName
forall name.
Maybe (Located Text) -> Located [Prop name] -> TopDecl name
DInterfaceConstraint 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 ParameterConstraint name
ps -> Signature name
s { sigConstraints = pcProps 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 [TopDecl PName]
ds =
  do [TopDecl PName] -> (TopDecl PName -> ParseM ()) -> ParseM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TopDecl PName]
ds \case
       DParamDecl Range
l Signature PName
_            -> Range -> ParseM ()
forall {a}. Range -> ParseM a
mainParamError Range
l
       DModParam ModParam PName
p               -> Range -> ParseM ()
forall {a}. Range -> ParseM a
mainParamError (Located (ImpName PName) -> Range
forall a. Located a -> Range
srcRange (ModParam PName -> Located (ImpName PName)
forall name. ModParam name -> Located (ImpName name)
mpSignature ModParam PName
p))
       DInterfaceConstraint Maybe (Located Text)
_ Located [Prop PName]
ps -> Range -> ParseM ()
forall {a}. Range -> ParseM a
mainParamError (Located [Prop PName] -> Range
forall a. Located a -> Range
srcRange Located [Prop PName]
ps)
       TopDecl PName
_                         -> () -> ParseM ()
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
     [Char]
src <- Config -> [Char]
cfgSource (Config -> [Char]) -> ParseM Config -> ParseM [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseM Config
askConfig
     Maybe (Located Text) -> Module PName -> ParseM [Module PName]
mkTopMods Maybe (Located Text)
forall a. Maybe a
Nothing (Module PName -> ParseM [Module PName])
-> Module PName -> ParseM [Module PName]
forall a b. (a -> b) -> a -> b
$
        Located ModName -> [TopDecl PName] -> Module PName
mkModule Located
          { srcRange :: Range
srcRange = Range
emptyRange
          , thing :: ModName
thing    = [Char] -> ModName
mainModName [Char]
src
          }
                          [TopDecl PName]
ds
  where
  mainParamError :: Range -> ParseM a
mainParamError Range
l = Range -> [[Char]] -> ParseM a
forall a. Range -> [[Char]] -> ParseM a
errorMessage Range
l
    [[Char]
"Unnamed module cannot be parameterized"]

-- | 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
         , mDocTop :: Maybe (Located Text)
mDocTop  = Maybe (Located Text)
forall a. Maybe a
Nothing
         }

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
         , mDocTop :: Maybe (Located Text)
mDocTop  = Maybe (Located Text)
forall a. Maybe a
Nothing
         }


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
lab)
            [[Char]
"Invalid record field.  Perhaps you meant to update a record?"]
  where
    -- The list of field updates in an UpdField should always be non-empty.
    lab :: Located Selector
lab = case [Located Selector]
ls of
            Located Selector
lab':[Located Selector]
_ -> Located Selector
lab'
            [] -> [Char] -> [[Char]] -> Located Selector
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"ufToNamed" [[Char]
"UpdField with empty labels"]

-- | The returned list of 'Selector's will be non-empty.
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 l :: Located Selector
l =
                 case [Located Selector]
ls of
                   Located Selector
l':[Located Selector]
_ -> Located Selector
l'
                   [] -> [Char] -> [[Char]] -> Located Selector
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"exprToFieldPath" [[Char]
"empty list of selectors"]
           let rng :: Range
rng = Range
loc { from = to (srcRange l) }
           [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) ->
  Maybe (Located Text) ->
  ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport :: Range
-> Located (ImpName PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> Maybe (Located Text)
-> 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])
-> Maybe (Located Text)
-> 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]) ->
  Maybe (Located Text) ->
  ParseM (Located (ImportG (ImpName PName)))

mkImport :: Range
-> Located (ImpName PName)
-> Maybe (ModuleInstanceArgs PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> Maybe (Located [Decl PName])
-> Maybe (Located Text)
-> 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 Maybe (Located Text)
doc =
  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
                                 , iDoc :: Maybe (Located Text)
iDoc       = Maybe (Located Text)
doc
                                 }
                  }
  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 :: Maybe (Located Text) -> Module PName -> ParseM [Module PName]
mkTopMods :: Maybe (Located Text) -> Module PName -> ParseM [Module PName]
mkTopMods Maybe (Located Text)
doc Module PName
m =
 do (Module PName
m', [Module PName]
ms) <- Module PName -> ParseM (Module PName, [Module PName])
forall name.
MkAnon name =>
ModuleG name PName
-> ParseM (ModuleG name PName, [ModuleG name PName])
desugarMod Module PName
m { mDocTop = doc }
    [Module PName] -> ParseM [Module PName]
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Module PName]
ms [Module PName] -> [Module PName] -> [Module PName]
forall a. [a] -> [a] -> [a]
++ [Module PName
m'])

mkTopSig :: Maybe (Located Text) -> Located ModName -> Signature PName -> [Module PName]
mkTopSig :: Maybe (Located Text)
-> Located ModName -> Signature PName -> [Module PName]
mkTopSig Maybe (Located Text)
doc 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
           , mDocTop :: Maybe (Located Text)
mDocTop  = Maybe (Located Text)
doc
           }
  ]


class MkAnon t where
  mkAnon    :: AnonThing -> t -> t
  toImpName :: t -> ImpName PName

data AnonThing = AnonArg Int Int
                -- ^ The ints are line, column used for disambiguation
               | AnonIfaceMod

instance MkAnon ModName where
  mkAnon :: AnonThing -> ModName -> ModName
mkAnon AnonThing
what   = case AnonThing
what of
                    AnonArg Int
l Int
c  -> Int -> Int -> ModName -> ModName
modNameArg Int
l Int
c
                    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
                    AnonArg Int
l Int
c  -> Ident -> Ident -> Ident
forall a b. a -> b -> a
const (Int -> Int -> Ident
identAnonArg Int
l Int
c)
                    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

-- | Desugar a module returning first the updated original module and a
-- list of any new modules generated by desugaring.
desugarMod :: MkAnon name => ModuleG name PName -> ParseM (ModuleG name PName, [ModuleG name PName])
desugarMod :: forall name.
MkAnon name =>
ModuleG name PName
-> ParseM (ModuleG name PName, [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 (Int -> Int -> AnonThing
AnonArg (Position -> Int
line Position
pos) (Position -> Int
col Position
pos)) (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))
             pos :: Position
pos    = Range -> Position
from (Located name -> Range
forall a. Located a -> Range
srcRange Located name
nm)
             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, [ModuleG name PName])
-> ParseM (ModuleG name PName, [ModuleG name PName])
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( ModuleG name PName
mo { mDef = FunctorInstance f as' mempty }
              , [ 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
                    , mDocTop :: Maybe (Located Text)
mDocTop = Maybe (Located Text)
forall a. Maybe a
Nothing
                    }]
              )

    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, [ModuleG name PName])
-> ParseM (ModuleG name PName, [ModuleG name PName])
forall a. a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleG name PName
mo {mDef = NormalModule newDs }, [ModuleG name PName]
newMs)

    ModuleDefinition PName
_ -> (ModuleG name PName, [ModuleG name PName])
-> ParseM (ModuleG name PName, [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
                             , mDocTop :: Maybe (Located Text)
mDocTop = Maybe (Located Text)
forall a. Maybe a
Nothing
                             }
                     ]
                  , [ 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
mo', [ModuleG PName PName]
ms) <- ModuleG PName PName
-> ParseM (ModuleG PName PName, [ModuleG PName PName])
forall name.
MkAnon name =>
ModuleG name PName
-> ParseM (ModuleG name PName, [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
                          { tlExport :: ExportType
tlExport = TopLevel (NestedModule PName) -> ExportType
forall a. TopLevel a -> ExportType
tlExport TopLevel (NestedModule PName)
tl
                          , tlValue :: NestedModule PName
tlValue = ModuleG PName PName -> NestedModule PName
forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG PName PName
m
                          , tlDoc :: Maybe (Located Text)
tlDoc = Maybe (Located Text)
forall a. Maybe a
Nothing -- generated modules have no docstrings
                          }
                      | ModuleG PName PName
m <- [ModuleG PName PName]
ms] [TopDecl PName] -> [TopDecl PName] -> [TopDecl PName]
forall a. [a] -> [a] -> [a]
++ [TopLevel (NestedModule PName) -> TopDecl PName
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
tl { tlValue = NestedModule mo' }])
                    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
m, [ModuleG PName PName]
ms) <- ModuleG PName PName
-> ParseM (ModuleG PName PName, [ModuleG PName PName])
forall name.
MkAnon name =>
ModuleG name PName
-> ParseM (ModuleG name PName, [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
                  , mDocTop :: Maybe (Located Text)
mDocTop  = Maybe (Located Text)
forall a. Maybe a
Nothing
                  }
     [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 [ModuleG PName PName]
-> [ModuleG PName PName] -> [ModuleG PName PName]
forall a. [a] -> [a] -> [a]
++ [ModuleG PName PName
m]))

  where
  iname :: PName
iname = Ident -> PName
mkUnqual
        (Ident -> PName) -> Ident -> PName
forall a b. (a -> b) -> a -> b
$ let pos :: Position
pos = Range -> Position
from (Located (ImportG (ImpName PName)) -> Range
forall a. Located a -> Range
srcRange Located (ImportG (ImpName PName))
i)
          in Int -> Int -> Ident
identAnonInstImport (Position -> Int
line Position
pos) (Position -> Int
col Position
pos)

  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
                       }