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

{-# LANGUAGE Safe #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where

import qualified Data.Text as Text
import Data.Char(isAlphaNum)
import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Data.Maybe(mapMaybe)
import Data.List(foldl')
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard,msum)
import qualified Control.Monad.Fail as Fail
import           Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import Text.Read(readMaybe)

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat


import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Token(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident( packModName,packIdent,modNameChunks
                          , identAnonArg, identAnonIfaceMod
                          , modNameArg, modNameIfaceMod
                          , modNameToText, modNameIsNormal
                          , modNameToNormalModName
                          , unpackIdent
                          )
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Cryptol.Utils.RecordMap


parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString :: forall a. Config -> ParseM a -> FilePath -> Either ParseError a
parseString Config
cfg ParseM a
p FilePath
cs = forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p (FilePath -> Text
T.pack FilePath
cs)

parse :: Config -> ParseM a -> Text -> Either ParseError a
parse :: forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p Text
cs    = case forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
p Config
cfg Position
eofPos S { sPrevTok :: Maybe (Located Token)
sPrevTok = forall a. Maybe a
Nothing
                                            , sTokens :: [Located Token]
sTokens = [Located Token]
toks
                                            , sNextTyParamNum :: Int
sNextTyParamNum = Int
0
                                            } of
                      Left ParseError
err    -> forall a b. a -> Either a b
Left ParseError
err
                      Right (a
a,S
_) -> forall a b. b -> Either a b
Right a
a
  where ([Located Token]
toks,Position
eofPos) = Config -> Text -> ([Located Token], Position)
lexer Config
cfg Text
cs


{- The parser is parameterized by the pozition of the final token. -}
newtype ParseM a =
  P { forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP :: Config -> Position -> S -> Either ParseError (a,S) }


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

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

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

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

ppError :: ParseError -> Doc

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

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

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

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

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

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

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

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

instance Monad ParseM where
  return :: forall a. a -> ParseM a
return    = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParseM a
m >>= :: forall a b. ParseM a -> (a -> ParseM b) -> ParseM b
>>= a -> ParseM b
k   = forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
cfg Position
p S
s1 -> case forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
m Config
cfg Position
p S
s1 of
                            Left ParseError
e       -> forall a b. a -> Either a b
Left ParseError
e
                            Right (a
a,S
s2) -> forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (a -> ParseM b
k a
a) Config
cfg Position
p S
s2)

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

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

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

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

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









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

-- | 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 forall a. Located a -> a
thing Located (ImpName PName)
lsig of
        ImpTop ModName
t
          | ModName -> Bool
modNameIsNormal ModName
t -> FilePath -> Ident
packIdent (forall a. [a] -> a
last (ModName -> [FilePath]
modNameChunks ModName
t))
          | Bool
otherwise         -> Ident -> Ident
identAnonIfaceMod
                               forall a b. (a -> b) -> a -> b
$ FilePath -> Ident
packIdent
                               forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last
                               forall a b. (a -> b) -> a -> b
$ ModName -> [FilePath]
modNameChunks
                               forall a b. (a -> b) -> a -> b
$ ModName -> ModName
modNameToNormalModName ModName
t
        ImpNested PName
nm ->
          case PName
nm of
            UnQual Ident
i -> Ident
i
            Qual ModName
_ Ident
i -> Ident
i
            NewName {} -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkModParamName" [FilePath
"Unexpected NewName",forall a. Show a => a -> FilePath
show Located (ImpName PName)
lsig]
    Just Located ModName
m -> FilePath -> Ident
packIdent (forall a. [a] -> a
last (ModName -> [FilePath]
modNameChunks (forall a. Located a -> a
thing Located ModName
m)))

-- 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 = forall n.
[TParam n] -> [Prop n] -> Type n -> Maybe Range -> Schema n
Forall [TParam PName]
xs [Prop PName]
ps Type PName
t forall a. Maybe a
Nothing

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

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

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

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

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

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

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


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

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

fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit :: Located Token -> ParseM (Located FilePath)
fromStrLit Located Token
loc = case Token -> TokenT
tokenType (forall a. Located a -> a
thing Located Token
loc) of
  StrLit FilePath
str -> forall (m :: * -> *) a. Monad m => a -> m a
return Located Token
loc { thing :: FilePath
thing = FilePath
str }
  TokenT
_          -> forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange Located Token
loc) [FilePath
"Expected a string literal"]


validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
ty =
  case Type PName
ty of
    TLocated Type PName
t Range
r -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
r Type PName
t
    TRecord {}   -> forall a. FilePath -> ParseM a
bad FilePath
"Record types"
    TTyApp {}    -> forall a. FilePath -> ParseM a
bad FilePath
"Explicit type application"
    TTuple {}    -> forall a. FilePath -> ParseM a
bad FilePath
"Tuple types"
    TFun {}      -> forall a. FilePath -> ParseM a
bad FilePath
"Function types"
    TSeq {}      -> forall a. FilePath -> ParseM a
bad FilePath
"Sequence types"
    Type PName
TBit         -> forall a. FilePath -> ParseM a
bad FilePath
"Type bit"
    TNum {}      -> ParseM (Type PName)
ok
    TChar {}     -> ParseM (Type PName)
ok
    Type PName
TWild        -> forall a. FilePath -> ParseM a
bad FilePath
"Wildcard types"
    TUser {}     -> ParseM (Type PName)
ok

    TParens Type PName
t Maybe Kind
mb -> case Maybe Kind
mb of
                      Maybe Kind
Nothing -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
t
                      Just Kind
_  -> forall a. FilePath -> ParseM a
bad FilePath
"kind annotation"
    TInfix{}     -> ParseM (Type PName)
ok

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

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

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


-- | 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
       forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
eFirst,Expr PName
eLast) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f [Expr PName]
xs)

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

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

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

  {- 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 (forall a. a -> Maybe a
Just Range
rng))
      ETypeVal Type PName
t -> forall {a}.
Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr
      ESel Expr PName
e' Selector
s  -> ( \([TypeInst PName]
fs,[Selector]
ss,Maybe Range
r) -> ([TypeInst PName]
fs,Selector
sforall a. a -> [a] -> [a]
:[Selector]
ss,Maybe Range
r) ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' Maybe Range
mr
      Expr PName
_          ->  forall a. Maybe a
Nothing

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

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

-- 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 = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
x,Expr PName
y) forall a b. (a -> b) -> a -> b
$ forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix Expr PName
x LPName
f Fixity
defaultFixity Expr PName
y

-- 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 (forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, forall n. Expr n -> Maybe (Expr n, Type n)
asETyped forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expr PName)
e2, forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1' Maybe (Expr PName)
e2 Expr PName
e3 (forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 (forall a. a -> Maybe a
Just Expr PName
e2') Expr PName
e3 (forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3' (forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 forall a. Maybe a
Nothing
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
r [FilePath
"A sequence enumeration may have at most one element type annotation."]

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

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

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

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


asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped :: forall n. Expr n -> Maybe (Expr n, Type n)
asETyped (ELocated Expr n
e Range
_) = forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr n
e
asETyped (ETyped Expr n
e Type n
t) = forall a. a -> Maybe a
Just (Expr n
e, Type n
t)
asETyped Expr n
_ = forall a. Maybe a
Nothing

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

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

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

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


-- | 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 = forall n. Type n -> Range -> Type n
TLocated (forall n. [Named (Type n)] -> Type n
TTyApp (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. a -> Named a
toField [Type PName]
ts)) Range
r
  where noName :: Located Ident
noName    = Located { srcRange :: Range
srcRange = Range
r, thing :: Ident
thing = Text -> Ident
mkIdent (FilePath -> Text
T.pack FilePath
"") }
        toField :: a -> Named a
toField a
t = Named { name :: Located Ident
name = Located Ident
noName, value :: a
value = a
t }

exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
e Decl PName
d = forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel { tlExport :: ExportType
tlExport = ExportType
e
                                     , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
mbDoc
                                     , tlValue :: Decl PName
tlValue  = Decl PName
d }

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

exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule Maybe (Located Text)
mbDoc NestedModule PName
m = forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel { tlExport :: ExportType
tlExport = ExportType
Public
                                        , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
mbDoc
                                        , tlValue :: NestedModule PName
tlValue  = NestedModule PName
m }

mkParFun :: Maybe (Located Text) ->
            Located PName ->
            Schema PName ->
            ParamDecl PName
mkParFun :: Maybe (Located Text) -> LPName -> Schema PName -> ParamDecl PName
mkParFun Maybe (Located Text)
mbDoc LPName
n Schema PName
s = forall name. ParameterFun name -> ParamDecl name
DParameterFun ParameterFun { pfName :: LPName
pfName = LPName
n
                                                , pfSchema :: Schema PName
pfSchema = Schema PName
s
                                                , pfDoc :: Maybe Text
pfDoc = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
                                                , pfFixity :: Maybe Fixity
pfFixity = forall a. Maybe a
Nothing
                                                }

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

changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport ExportType
e = forall a b. (a -> b) -> [a] -> [b]
map forall {name}. TopDecl name -> TopDecl name
change
  where
  change :: TopDecl name -> TopDecl name
change TopDecl name
decl =
    case TopDecl name
decl of
      Decl TopLevel (Decl name)
d                  -> forall name. TopLevel (Decl name) -> TopDecl name
Decl      TopLevel (Decl name)
d { tlExport :: ExportType
tlExport = ExportType
e }
      DPrimType TopLevel (PrimType name)
t             -> forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType name)
t { tlExport :: ExportType
tlExport = ExportType
e }
      TDNewtype TopLevel (Newtype name)
n             -> forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel (Newtype name)
n { tlExport :: ExportType
tlExport = ExportType
e }
      DModule TopLevel (NestedModule name)
m               -> forall name. TopLevel (NestedModule name) -> TopDecl name
DModule   TopLevel (NestedModule name)
m { tlExport :: ExportType
tlExport = ExportType
e }
      DModParam {}            -> TopDecl name
decl
      Include{}               -> TopDecl name
decl
      DImport{}               -> TopDecl name
decl
      DParamDecl{}            -> TopDecl name
decl
      DInterfaceConstraint {} -> TopDecl name
decl

mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst Named (Type PName)
x | Ident -> Bool
nullIdent (forall a. Located a -> a
thing (forall a. Named a -> Located Ident
name Named (Type PName)
x)) = forall name. Type name -> TypeInst name
PosInst (forall a. Named a -> a
value Named (Type PName)
x)
             | Bool
otherwise                  = forall name. Named (Type name) -> TypeInst name
NamedInst Named (Type PName)
x


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


mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkTySyn Type PName
thead Type PName
tdef =
  do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. TySyn name -> Decl name
DType (forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn LPName
nm forall a. Maybe a
Nothing [TParam PName]
params Type PName
tdef))

mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkPropSyn Type PName
thead Type PName
tdef =
  do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
     [Prop PName]
ps          <- forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
tdef
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. PropSyn name -> Decl name
DProp (forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn LPName
nm forall a. Maybe a
Nothing [TParam PName]
params [Prop PName]
ps))

mkNewtype ::
  Type PName ->
  Located (RecordMap Ident (Range, Type PName)) ->
  ParseM (Newtype PName)
mkNewtype :: Type PName
-> Located (RecordMap Ident (Range, Type PName))
-> ParseM (Newtype PName)
mkNewtype Type PName
thead Located (RecordMap Ident (Range, Type PName))
def =
  do (LPName
nm,[TParam PName]
params) <- Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
thead
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name.
Located name
-> [TParam name] -> name -> Rec (Type name) -> Newtype name
Newtype LPName
nm [TParam PName]
params (forall a. Located a -> a
thing LPName
nm) (forall a. Located a -> a
thing Located (RecordMap Ident (Range, Type PName))
def))

typeToDecl :: Type PName -> ParseM (Located PName, [TParam PName])
typeToDecl :: Type PName -> ParseM (LPName, [TParam PName])
typeToDecl Type PName
ty0 =
  case Type PName
ty0 of
    TLocated Type PName
ty Range
loc -> Range -> Type PName -> ParseM (LPName, [TParam PName])
goD Range
loc Type PName
ty
    Type PName
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"typeToDecl" [FilePath
"Type location is missing."]

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


  goN :: Range -> PName -> ParseM ()
goN Range
loc PName
n =
    case PName
n of
      UnQual {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PName
_         -> forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [FilePath
"Invalid declaration name"]

  goP :: Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
ty =
    case Type PName
ty of
      TLocated Type PName
ty1 Range
loc1 -> Range -> Type PName -> ParseM (TParam PName)
goP Range
loc1 Type PName
ty1

      TUser PName
f [] ->
        do Range -> PName -> ParseM ()
goN Range
loc PName
f
           forall (f :: * -> *) a. Applicative f => a -> f a
pure TParam { tpName :: PName
tpName = PName
f, tpKind :: Maybe Kind
tpKind = forall a. Maybe a
Nothing, tpRange :: Maybe Range
tpRange = forall a. a -> Maybe a
Just Range
loc }

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

      TInfix {}     -> forall {a}. Range -> ParseM a
badP Range
loc
      TUser {}      -> forall {a}. Range -> ParseM a
badP Range
loc
      TFun {}       -> forall {a}. Range -> ParseM a
badP Range
loc
      TSeq {}       -> forall {a}. Range -> ParseM a
badP Range
loc
      TBit {}       -> forall {a}. Range -> ParseM a
badP Range
loc
      TNum {}       -> forall {a}. Range -> ParseM a
badP Range
loc
      TChar {}      -> forall {a}. Range -> ParseM a
badP Range
loc
      TRecord {}    -> forall {a}. Range -> ParseM a
badP Range
loc
      TWild {}      -> forall {a}. Range -> ParseM a
badP Range
loc
      TTyApp {}     -> forall {a}. Range -> ParseM a
badP Range
loc
      TTuple {}     -> forall {a}. Range -> ParseM a
badP Range
loc


  goD :: Range -> Type PName -> ParseM (LPName, [TParam PName])
goD Range
loc Type PName
ty =
    case Type PName
ty of

      TLocated Type PName
ty1 Range
loc1 -> Range -> Type PName -> ParseM (LPName, [TParam PName])
goD Range
loc1 Type PName
ty1

      TUser PName
f [Type PName]
ts ->
        do Range -> PName -> ParseM ()
goN Range
loc PName
f
           [TParam PName]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type PName -> ParseM (TParam PName)
goP Range
loc) [Type PName]
ts
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located { thing :: PName
thing = PName
f, srcRange :: Range
srcRange = Range
loc },[TParam PName]
ps)

      TInfix Type PName
l LPName
f Fixity
_ Type PName
r ->
        do Range -> PName -> ParseM ()
goN (forall a. Located a -> Range
srcRange LPName
f) (forall a. Located a -> a
thing LPName
f)
           TParam PName
a  <- Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
l
           TParam PName
b  <- Range -> Type PName -> ParseM (TParam PName)
goP Range
loc Type PName
r
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (LPName
f,[TParam PName
a,TParam PName
b])

      TFun {}       -> forall {a}. Range -> ParseM a
bad Range
loc
      TSeq {}       -> forall {a}. Range -> ParseM a
bad Range
loc
      TBit {}       -> forall {a}. Range -> ParseM a
bad Range
loc
      TNum {}       -> forall {a}. Range -> ParseM a
bad Range
loc
      TChar {}      -> forall {a}. Range -> ParseM a
bad Range
loc
      TRecord {}    -> forall {a}. Range -> ParseM a
bad Range
loc
      TWild {}      -> forall {a}. Range -> ParseM a
bad Range
loc
      TTyApp {}     -> forall {a}. Range -> ParseM a
bad Range
loc
      TTuple {}     -> forall {a}. Range -> ParseM a
bad Range
loc
      TParens {}    -> forall {a}. Range -> ParseM a
bad Range
loc

polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm Range
rng Integer
k Integer
p
  | Integer
k forall a. Eq a => a -> a -> Bool
== Integer
0          = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Integer
p)
  | Integer
k forall a. Eq a => a -> a -> Bool
== Integer
1          = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Integer
p)
  | Bool
otherwise       = forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
rng [FilePath
"Invalid polynomial coefficient"]

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

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

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

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

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


-- 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 = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (LPName
f,Expr PName
e) forall a b. (a -> b) -> a -> b
$
                    forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName       = LPName
f
                               , bParams :: [Pattern PName]
bParams     = forall a. [a] -> [a]
reverse [Pattern PName]
ps
                               , bDef :: Located (BindDef PName)
bDef        = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (forall a. Range -> a -> Located a
Located Range
emptyRange (forall name. Expr name -> BindDef name
DExpr Expr PName
e))
                               , bSignature :: Maybe (Schema PName)
bSignature  = forall a. Maybe a
Nothing
                               , bPragmas :: [Pragma]
bPragmas    = [Pragma
PragmaProperty]
                               , bMono :: Bool
bMono       = Bool
False
                               , bInfix :: Bool
bInfix      = Bool
False
                               , bFixity :: Maybe Fixity
bFixity     = forall a. Maybe a
Nothing
                               , bDoc :: Maybe Text
bDoc        = forall a. Maybe a
Nothing
                               , bExport :: ExportType
bExport     = ExportType
Public
                               }

-- 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 =
  forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName       = LPName
f
             , bParams :: [Pattern PName]
bParams     = forall a. [a] -> [a]
reverse [Pattern PName]
ps
             , bDef :: Located (BindDef PName)
bDef        = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (forall a. Range -> a -> Located a
Located Range
emptyRange (forall name. Expr name -> BindDef name
DExpr Expr PName
rhs))
             , bSignature :: Maybe (Schema PName)
bSignature  = forall a. Maybe a
Nothing
             , bPragmas :: [Pragma]
bPragmas    = []
             , bMono :: Bool
bMono       = Bool
False
             , bInfix :: Bool
bInfix      = Bool
False
             , bFixity :: Maybe Fixity
bFixity     = forall a. Maybe a
Nothing
             , bDoc :: Maybe Text
bDoc        = forall a. Maybe a
Nothing
             , bExport :: ExportType
bExport     = ExportType
Public
             }
  where
    rhs :: Expr PName
    rhs :: Expr PName
rhs = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate (forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
e

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

mkConstantPropGuardsDecl ::
  LPName -> [PropGuardCase PName] -> ParseM (Decl PName)
mkConstantPropGuardsDecl :: LPName -> [PropGuardCase PName] -> ParseM (Decl PName)
mkConstantPropGuardsDecl LPName
f [PropGuardCase PName]
guards =
  LPName
-> ([Pattern PName], [Pattern PName])
-> [PropGuardCase PName]
-> ParseM (Decl PName)
mkPropGuardsDecl LPName
f ([],[]) [PropGuardCase PName]
guards

-- 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
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ps = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate (forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body
  | Bool
otherwise = forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun forall n. FunDesc n
emptyFunDesc (forall a. [a] -> [a]
reverse [Pattern PName]
ps) ([Pattern PName] -> Expr PName -> Expr PName
mkGenerate (forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body)

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

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

mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl = BindDef PName
-> Maybe (Located Text)
-> LPName
-> Schema PName
-> [TopDecl PName]
mkNoImplDecl forall name. BindDef name
DPrim

mkForeignDecl ::
  Maybe (Located Text) -> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl :: Maybe (Located Text)
-> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl Maybe (Located Text)
mbDoc LPName
nm Schema PName
ty =
  do let txt :: FilePath
txt = Ident -> FilePath
unpackIdent (PName -> Ident
getIdent (forall a. Located a -> a
thing LPName
nm))
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isOk FilePath
txt)
       (forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange LPName
nm)
            [ FilePath
"`" forall a. [a] -> [a] -> [a]
++ FilePath
txt forall a. [a] -> [a] -> [a]
++ FilePath
"` is not a valid foreign name."
            , FilePath
"The name should contain only alpha-numeric characters or '_'."
            ])
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (BindDef PName
-> Maybe (Located Text)
-> LPName
-> Schema PName
-> [TopDecl PName]
mkNoImplDecl forall name. BindDef name
DForeign Maybe (Located Text)
mbDoc LPName
nm Schema PName
ty)
  where
  isOk :: Char -> Bool
isOk Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c

-- | 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)
mbDoc ExportType
Public
    forall a b. (a -> b) -> a -> b
$ forall name. Bind name -> Decl name
DBind Bind { bName :: LPName
bName      = LPName
ln
                 , bParams :: [Pattern PName]
bParams    = []
                 , bDef :: Located (BindDef PName)
bDef       = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Schema PName
sig (forall a. Range -> a -> Located a
Located Range
emptyRange BindDef PName
def)
                 , bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing
                 , bPragmas :: [Pragma]
bPragmas   = []
                 , bMono :: Bool
bMono      = Bool
False
                 , bInfix :: Bool
bInfix     = Ident -> Bool
isInfixIdent (PName -> Ident
getIdent (forall a. Located a -> a
thing LPName
ln))
                 , bFixity :: Maybe Fixity
bFixity    = forall a. Maybe a
Nothing
                 , bDoc :: Maybe Text
bDoc       = forall a. Maybe a
Nothing
                 , bExport :: ExportType
bExport    = ExportType
Public
                 }
  , Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl forall a. Maybe a
Nothing ExportType
Public
    forall a b. (a -> b) -> a -> b
$ forall name. [Located name] -> Schema name -> Decl name
DSignature [LPName
ln] Schema PName
sig
  ]

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

         let ki :: Located Kind
ki = Located Kind
finK { thing :: Kind
thing = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Kind -> Kind -> Kind
KFun (forall a. Located a -> a
thing Located Kind
finK) [Kind]
ins }

         forall (f :: * -> *) a. Applicative f => a -> f a
pure [ forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel
                  { tlExport :: ExportType
tlExport = ExportType
Public
                  , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
mbDoc
                  , tlValue :: PrimType PName
tlValue  = PrimType { primTName :: LPName
primTName   = LPName
n
                                        , primTKind :: Located Kind
primTKind   = Located Kind
ki
                                        , primTCts :: ([TParam PName], [Prop PName])
primTCts    = ([TParam PName]
as',[Prop PName]
qs)
                                        , primTFixity :: Maybe Fixity
primTFixity = forall a. Maybe a
Nothing
                                        }
                 }
              ]

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

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

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

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

  -- 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ys) Bool -> Bool -> Bool
&& [a] -> Bool
distinct [a]
ys

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


-- | 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 :: Text
thing = Text
docStr }
  where

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

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

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

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

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

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

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


distrLoc :: Located [a] -> [Located a]
distrLoc :: forall a. Located [a] -> [Located a]
distrLoc Located [a]
x = [ Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
a } | a
a <- forall a. Located a -> a
thing Located [a]
x ]
  where r :: Range
r = forall a. Located a -> Range
srcRange Located [a]
x

mkPropGuards :: Type PName -> ParseM [Located (Prop PName)]
mkPropGuards :: Type PName -> ParseM [Located (Prop PName)]
mkPropGuards Type PName
ty =
  do Located [Prop PName]
lp <- Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty
     forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located [Prop PName]
lp { thing :: Prop PName
thing = Prop PName
p } | Prop PName
p <- forall a. Located a -> a
thing Located [Prop PName]
lp ]

mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty =
  case Type PName
ty of
    TLocated Type PName
t Range
r -> forall a. Range -> a -> Located a
Located Range
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall {n}. Range -> Type n -> ParseM [Prop n]
props Range
r Type PName
t
    Type PName
_            -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"Parser" [ FilePath
"Invalid type given to mkProp"
                                   , FilePath
"expected a location"
                                   , forall a. Show a => a -> FilePath
show Type PName
ty ]

  where

  props :: Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t =
    case Type n
t of
      TInfix{}       -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall n. Type n -> Prop n
CType Type n
t]
      TUser{}        -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall n. Type n -> Prop n
CType Type n
t]
      TTuple [Type n]
ts      -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type n -> ParseM [Prop n]
props Range
r) [Type n]
ts
      TParens Type n
t' Maybe Kind
mb  -> case Maybe Kind
mb of
                          Maybe Kind
Nothing -> Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t'
                          Just Kind
_  -> forall a. ParseM a
err

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

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

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

-- | 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 = forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
ds
                        }

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

mkSigDecl :: Maybe (Located Text) -> (Located PName,Signature PName) -> TopDecl PName
mkSigDecl :: Maybe (Located Text) -> (LPName, Signature PName) -> TopDecl PName
mkSigDecl Maybe (Located Text)
doc (LPName
nm,Signature PName
sig) =
  forall name. TopLevel (NestedModule name) -> TopDecl name
DModule
  TopLevel { tlExport :: ExportType
tlExport = ExportType
Public
           , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
doc
           , tlValue :: NestedModule PName
tlValue  = forall name. ModuleG name name -> NestedModule name
NestedModule
                        Module { mName :: LPName
mName = LPName
nm
                               , mDef :: ModuleDefinition PName
mDef  = forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
                               }
           }

mkInterfaceConstraint ::
  Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint :: Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint Maybe (Located Text)
mbDoc Type PName
ty =
  do Located [Prop PName]
ps <- Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty
     forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall name. Maybe Text -> Located [Prop name] -> TopDecl name
DInterfaceConstraint (forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc) Located [Prop PName]
ps]

mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls [ParamDecl PName]
ds = forall name. Range -> Signature name -> TopDecl name
DParamDecl Range
loc ([Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> Signature PName
mkInterface' [] [ParamDecl PName]
ds)
  where loc :: Range
loc = [Range] -> Range
rCombs (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall t. HasLoc t => t -> Maybe Range
getLoc [ParamDecl PName]
ds)

onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {mname}. Located (ImportG mname) -> ParseM ()
check
  where
  check :: Located (ImportG mname) -> ParseM ()
check Located (ImportG mname)
i =
    case forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (forall a. Located a -> a
thing Located (ImportG mname)
i) of
      Maybe (ModuleInstanceArgs PName)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ModuleInstanceArgs PName
_  ->
        forall a. Range -> [FilePath] -> ParseM a
errorMessage (forall a. Located a -> Range
srcRange Located (ImportG mname)
i)
          [ FilePath
"Functor instantiations are not supported in this context."
          , FilePath
"The imported entity needs to be just the name of a module."
          , FilePath
"A workaround would be to do the instantion in the outer context."
          ]

mkInterface' :: [Located (ImportG (ImpName PName))] ->
             [ParamDecl PName] -> Signature PName
mkInterface' :: [Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> Signature PName
mkInterface' [Located (ImportG (ImpName PName))]
is =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {name}. Signature name -> ParamDecl name -> Signature name
add
    Signature { sigImports :: [Located (ImportG (ImpName PName))]
sigImports     = [Located (ImportG (ImpName PName))]
is
              , sigTypeParams :: [ParameterType PName]
sigTypeParams  = []
              , sigDecls :: [SigDecl PName]
sigDecls       = []
              , sigConstraints :: [Located (Prop PName)]
sigConstraints = []
              , sigFunParams :: [ParameterFun PName]
sigFunParams   = []
              }
  where
  add :: Signature name -> ParamDecl name -> Signature name
add Signature name
s ParamDecl name
d =
    case ParamDecl name
d of
      DParameterType ParameterType name
pt       -> Signature name
s { sigTypeParams :: [ParameterType name]
sigTypeParams  = ParameterType name
pt  forall a. a -> [a] -> [a]
: forall name. Signature name -> [ParameterType name]
sigTypeParams Signature name
s  }
      DParameterConstraint [Located (Prop name)]
ps -> Signature name
s { sigConstraints :: [Located (Prop name)]
sigConstraints = [Located (Prop name)]
ps forall a. [a] -> [a] -> [a]
++ forall name. Signature name -> [Located (Prop name)]
sigConstraints Signature name
s }
      DParameterDecl SigDecl name
pd       -> Signature name
s { sigDecls :: [SigDecl name]
sigDecls       = SigDecl name
pd  forall a. a -> [a] -> [a]
: forall name. Signature name -> [SigDecl name]
sigDecls Signature name
s       }
      DParameterFun ParameterFun name
pf        -> Signature name
s { sigFunParams :: [ParameterFun name]
sigFunParams   = ParameterFun name
pf  forall a. a -> [a] -> [a]
: forall name. Signature name -> [ParameterFun name]
sigFunParams Signature name
s   }



mkInterface :: [Located (ImportG (ImpName PName))] ->
             [ParamDecl PName] -> ParseM (Signature PName)
mkInterface :: [Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> ParseM (Signature PName)
mkInterface [Located (ImportG (ImpName PName))]
is [ParamDecl PName]
ps =
  do [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports [Located (ImportG (ImpName PName))]
is
     forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Located (ImportG (ImpName PName))]
-> [ParamDecl PName] -> Signature PName
mkInterface' [Located (ImportG (ImpName PName))]
is [ParamDecl PName]
ps)

mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn Maybe Text
mbDoc Decl PName
d =
  case Decl PName
d of
    DLocated Decl PName
d1 Range
_ -> Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn Maybe Text
mbDoc Decl PName
d1
    DType TySyn PName
ts    -> forall name. SigDecl name -> ParamDecl name
DParameterDecl (forall name. TySyn name -> Maybe Text -> SigDecl name
SigTySyn TySyn PName
ts Maybe Text
mbDoc)
    DProp PropSyn PName
ps    -> forall name. SigDecl name -> ParamDecl name
DParameterDecl (forall name. PropSyn name -> Maybe Text -> SigDecl name
SigPropSyn PropSyn PName
ps Maybe Text
mbDoc)
    Decl PName
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkIfacePropSyn" [ FilePath
"Unexpected declaration", forall a. Show a => a -> FilePath
show (forall a. PP a => a -> Doc
pp Decl PName
d) ]


-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule = Module PName -> ParseM [Module PName]
mkTopMods
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModName -> [TopDecl PName] -> Module PName
mkModule Located { srcRange :: Range
srcRange = Range
emptyRange
                                     , thing :: ModName
thing    = [Text] -> ModName
mkModName [FilePath -> Text
T.pack FilePath
"Main"]
                                     }

-- | 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   = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
fun (forall name. [TopDecl name] -> ModuleInstanceArgs name
DefaultInstAnonArg [TopDecl PName]
ds) forall a. Monoid a => a
mempty
         }

mkModuleInstance ::
  Located ModName ->
  Located (ImpName PName) ->
  ModuleInstanceArgs PName ->
  Module PName
mkModuleInstance :: Located ModName
-> Located (ImpName PName)
-> ModuleInstanceArgs PName
-> Module PName
mkModuleInstance Located ModName
m Located (ImpName PName)
f ModuleInstanceArgs PName
as =
  Module { mName :: Located ModName
mName = Located ModName
m
         , mDef :: ModuleDefinition PName
mDef  = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as forall name. Ord name => ModuleInstance name
emptyModuleInstance
         }


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

exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath Expr PName
e0 = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM [Located Selector]
go forall {a}. a
noLoc Expr PName
e0
  where
  noLoc :: a
noLoc = forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"selExprToSels" [FilePath
"Missing location?"]
  go :: Range -> Expr PName -> ParseM [Located Selector]
go Range
loc Expr PName
expr =
    case Expr PName
expr of
      ELocated Expr PName
e1 Range
r -> Range -> Expr PName -> ParseM [Located Selector]
go Range
r Expr PName
e1
      ESel Expr PName
e2 Selector
s ->
        do [Located Selector]
ls <- Range -> Expr PName -> ParseM [Located Selector]
go Range
loc Expr PName
e2
           let rng :: Range
rng = Range
loc { from :: Position
from = Range -> Position
to (forall a. Located a -> Range
srcRange (forall a. [a] -> a
head [Located Selector]
ls)) }
           forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located { thing :: Selector
thing = Selector
s, srcRange :: Range
srcRange = Range
rng } forall a. a -> [a] -> [a]
: [Located Selector]
ls)
      EVar (UnQual Ident
l) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located { thing :: Selector
thing = Ident -> Maybe [Ident] -> Selector
RecordSel Ident
l forall a. Maybe a
Nothing, srcRange :: Range
srcRange = Range
loc } ]

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

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

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


mkSelector :: Token -> Selector
mkSelector :: Token -> Selector
mkSelector Token
tok =
  case Token -> TokenT
tokenType Token
tok of
    Selector (TupleSelectorTok Int
n) -> Int -> Maybe Int -> Selector
TupleSel Int
n forall a. Maybe a
Nothing
    Selector (RecordSelectorTok Text
t) -> Ident -> Maybe [Ident] -> Selector
RecordSel (Text -> Ident
mkIdent Text
t) forall a. Maybe a
Nothing
    TokenT
_ -> forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"mkSelector" [ FilePath
"Unexpected selector token", forall a. Show a => a -> FilePath
show Token
tok ]

mkBacktickImport ::
  Range ->
  Located (ImpName PName) ->
  Maybe (Located ModName) ->
  Maybe (Located ImportSpec) ->
  ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport :: Range
-> Located (ImpName PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport Range
loc Located (ImpName PName)
impName Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec =
  Range
-> Located (ImpName PName)
-> Maybe (ModuleInstanceArgs PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> Maybe (Located [Decl PName])
-> ParseM (Located (ImportG (ImpName PName)))
mkImport Range
loc Located (ImpName PName)
impName (forall a. a -> Maybe a
Just forall {name}. ModuleInstanceArgs name
inst) Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec forall a. Maybe a
Nothing
  where
  inst :: ModuleInstanceArgs name
inst = forall name.
Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
DefaultInstArg (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall name. ModuleInstanceArg name
AddParams) Located (ImpName PName)
impName)


mkImport ::
  Range ->
  Located (ImpName PName) ->
  Maybe (ModuleInstanceArgs PName) ->
  Maybe (Located ModName) ->
  Maybe (Located ImportSpec) ->
  Maybe (Located [Decl PName]) ->
  ParseM (Located (ImportG (ImpName PName)))

mkImport :: Range
-> Located (ImpName PName)
-> Maybe (ModuleInstanceArgs PName)
-> Maybe (Located ModName)
-> Maybe (Located ImportSpec)
-> Maybe (Located [Decl PName])
-> ParseM (Located (ImportG (ImpName PName)))
mkImport Range
loc Located (ImpName PName)
impName Maybe (ModuleInstanceArgs PName)
optInst Maybe (Located ModName)
mbAs Maybe (Located ImportSpec)
mbImportSpec Maybe (Located [Decl PName])
optImportWhere =
  do Maybe (ModuleInstanceArgs PName)
i <- ParseM (Maybe (ModuleInstanceArgs PName))
getInst
     let end :: Range
end = forall a. a -> Maybe a -> a
fromMaybe (forall a. Located a -> Range
srcRange Located (ImpName PName)
impName)
             forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ forall a. Located a -> Range
srcRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located [Decl PName])
optImportWhere
                    , forall a. Located a -> Range
srcRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ImportSpec)
mbImportSpec
                    , forall a. Located a -> Range
srcRange forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ModName)
mbAs
                    ]

     forall (f :: * -> *) a. Applicative f => a -> f a
pure Located { srcRange :: Range
srcRange = Range -> Range -> Range
rComb Range
loc Range
end
                  , thing :: ImportG (ImpName PName)
thing    = Import
                                 { iModule :: ImpName PName
iModule    = forall a. Located a -> a
thing Located (ImpName PName)
impName
                                 , iAs :: Maybe ModName
iAs        = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ModName)
mbAs
                                 , iSpec :: Maybe ImportSpec
iSpec      = forall a. Located a -> a
thing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located ImportSpec)
mbImportSpec
                                 , iInst :: Maybe (ModuleInstanceArgs PName)
iInst      = Maybe (ModuleInstanceArgs PName)
i
                                 }
                  }
  where
  getInst :: ParseM (Maybe (ModuleInstanceArgs PName))
getInst =
    case (Maybe (ModuleInstanceArgs PName)
optInst,Maybe (Located [Decl PName])
optImportWhere) of
      (Just ModuleInstanceArgs PName
_, Just Located [Decl PName]
_) ->
         forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
loc [ FilePath
"Invalid instantiating import."
                          , FilePath
"Import should have at most one of:"
                          , FilePath
"  * { } instantiation, or"
                          , FilePath
"  * where instantiation"
                          ]
      (Just ModuleInstanceArgs PName
a, Maybe (Located [Decl PName])
Nothing)  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ModuleInstanceArgs PName
a)
      (Maybe (ModuleInstanceArgs PName)
Nothing, Just Located [Decl PName]
a)  ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall name. [TopDecl name] -> ModuleInstanceArgs name
DefaultInstAnonArg (forall a b. (a -> b) -> [a] -> [b]
map forall {name}. Decl name -> TopDecl name
instTop (forall a. Located a -> a
thing Located [Decl PName]
a))))
         where
         instTop :: Decl name -> TopDecl name
instTop Decl name
d = forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel
                            { tlExport :: ExportType
tlExport = ExportType
Public
                            , tlDoc :: Maybe (Located Text)
tlDoc    = forall a. Maybe a
Nothing
                            , tlValue :: Decl name
tlValue  = Decl name
d
                            }
      (Maybe (ModuleInstanceArgs PName)
Nothing, Maybe (Located [Decl PName])
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing





mkTopMods :: Module PName -> ParseM [Module PName]
mkTopMods :: Module PName -> ParseM [Module PName]
mkTopMods = forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod

mkTopSig :: Located ModName -> Signature PName -> [Module PName]
mkTopSig :: Located ModName -> Signature PName -> [Module PName]
mkTopSig Located ModName
nm Signature PName
sig =
  [ Module { mName :: Located ModName
mName = Located ModName
nm
           , mDef :: ModuleDefinition PName
mDef  = forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
           }
  ]


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

data AnonThing = AnonArg | AnonIfaceMod

instance MkAnon ModName where
  mkAnon :: AnonThing -> ModName -> ModName
mkAnon AnonThing
what   = case AnonThing
what of
                    AnonThing
AnonArg      -> ModName -> ModName
modNameArg
                    AnonThing
AnonIfaceMod -> ModName -> ModName
modNameIfaceMod
  toImpName :: ModName -> ImpName PName
toImpName     = forall name. ModName -> ImpName name
ImpTop

instance MkAnon PName where
  mkAnon :: AnonThing -> PName -> PName
mkAnon AnonThing
what   = Ident -> PName
mkUnqual
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. case AnonThing
what of
                    AnonThing
AnonArg      -> Ident -> Ident
identAnonArg
                    AnonThing
AnonIfaceMod -> Ident -> Ident
identAnonIfaceMod
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. PName -> Ident
getIdent
  toImpName :: PName -> ImpName PName
toImpName     = forall name. name -> ImpName name
ImpNested


desugarMod :: MkAnon name => ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod :: forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod ModuleG name PName
mo =
  case forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG name PName
mo of

    FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
_ | DefaultInstAnonArg [TopDecl PName]
lds <- ModuleInstanceArgs PName
as ->
      do ([ModuleG name PName]
ms,[TopDecl PName]
lds') <- forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) [TopDecl PName]
lds
         case [ModuleG name PName]
ms of
           ModuleG name PName
m : [ModuleG name PName]
_ | InterfaceModule Signature PName
si <- forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG name PName
m
                 , Range
l : [Range]
_ <- forall a b. (a -> b) -> [a] -> [b]
map (forall a. Located a -> Range
srcRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. ParameterType name -> Located name
ptName) (forall name. Signature name -> [ParameterType name]
sigTypeParams Signature PName
si) forall a. [a] -> [a] -> [a]
++
                            forall a b. (a -> b) -> [a] -> [b]
map (forall a. Located a -> Range
srcRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. ParameterFun name -> Located name
pfName) (forall name. Signature name -> [ParameterFun name]
sigFunParams Signature PName
si) forall a. [a] -> [a] -> [a]
++
                            [ forall a. Located a -> Range
srcRange (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo) ] ->
              forall a. Range -> [FilePath] -> ParseM a
errorMessage Range
l
                [ FilePath
"Instantiation of a parameterized module may not itself be "
                  forall a. [a] -> [a] -> [a]
++ FilePath
"parameterized" ]
           [ModuleG name PName]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         let i :: name
i      = forall t. MkAnon t => AnonThing -> t -> t
mkAnon AnonThing
AnonArg (forall a. Located a -> a
thing (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo))
             nm :: Located name
nm     = Located { srcRange :: Range
srcRange = forall a. Located a -> Range
srcRange (forall mname name. ModuleG mname name -> Located mname
mName ModuleG name PName
mo), thing :: name
thing = name
i }
             as' :: ModuleInstanceArgs PName
as'    = forall name.
Located (ModuleInstanceArg name) -> ModuleInstanceArgs name
DefaultInstArg (forall name. ImpName name -> ModuleInstanceArg name
ModuleArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. MkAnon t => t -> ImpName PName
toImpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm)
         forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Module { mName :: Located name
mName = Located name
nm, mDef :: ModuleDefinition PName
mDef  = forall name. [TopDecl name] -> ModuleDefinition name
NormalModule [TopDecl PName]
lds' }
              , ModuleG name PName
mo { mDef :: ModuleDefinition PName
mDef = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as' forall a. Monoid a => a
mempty }
              ]

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

    ModuleDefinition PName
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [ModuleG name PName
mo]


desugarTopDs ::
  MkAnon name =>
  Located name ->
  [TopDecl PName] ->
  ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs :: forall name.
MkAnon name =>
Located name
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs Located name
ownerName = Signature PName
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
go forall {name}. Signature name
emptySig
  where
  isEmpty :: Signature name -> Bool
isEmpty Signature name
s =
    forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Signature name -> [ParameterType name]
sigTypeParams Signature name
s) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Signature name -> [Located (Prop name)]
sigConstraints Signature name
s) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Signature name -> [ParameterFun name]
sigFunParams Signature name
s)

  emptySig :: Signature name
emptySig = Signature
    { sigImports :: [Located (ImportG (ImpName name))]
sigImports      = []
    , sigTypeParams :: [ParameterType name]
sigTypeParams   = []
    , sigDecls :: [SigDecl name]
sigDecls        = []
    , sigConstraints :: [Located (Prop name)]
sigConstraints  = []
    , sigFunParams :: [ParameterFun name]
sigFunParams    = []
    }

  jnSig :: Signature name -> Signature name -> Signature name
jnSig Signature name
s1 Signature name
s2 = Signature { sigImports :: [Located (ImportG (ImpName name))]
sigImports      = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [Located (ImportG (ImpName name))]
sigImports
                          , sigTypeParams :: [ParameterType name]
sigTypeParams   = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [ParameterType name]
sigTypeParams
                          , sigDecls :: [SigDecl name]
sigDecls        = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [SigDecl name]
sigDecls
                          , sigConstraints :: [Located (Prop name)]
sigConstraints  = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [Located (Prop name)]
sigConstraints
                          , sigFunParams :: [ParameterFun name]
sigFunParams    = forall {a}. (Signature name -> [a]) -> [a]
j forall name. Signature name -> [ParameterFun name]
sigFunParams
                          }

      where
      j :: (Signature name -> [a]) -> [a]
j Signature name -> [a]
f = Signature name -> [a]
f Signature name
s1 forall a. [a] -> [a] -> [a]
++ Signature name -> [a]
f Signature name
s2

  addI :: Located (ImportG (ImpName name))
-> Signature name -> Signature name
addI Located (ImportG (ImpName name))
i Signature name
s = Signature name
s { sigImports :: [Located (ImportG (ImpName name))]
sigImports = Located (ImportG (ImpName name))
i forall a. a -> [a] -> [a]
: forall name. Signature name -> [Located (ImportG (ImpName name))]
sigImports Signature name
s }

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

      []
        | forall {name}. Signature name -> Bool
isEmpty Signature PName
sig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([],[])
        | Bool
otherwise ->
          do let nm :: Located name
nm = forall t. MkAnon t => AnonThing -> t -> t
mkAnon AnonThing
AnonIfaceMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
ownerName
             forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [ Module { mName :: Located name
mName = Located name
nm
                             , mDef :: ModuleDefinition PName
mDef = forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
sig
                             }
                     ]
                  , [ forall name. ModParam name -> TopDecl name
DModParam
                      ModParam
                        { mpSignature :: Located (ImpName PName)
mpSignature = forall t. MkAnon t => t -> ImpName PName
toImpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm
                        , mpAs :: Maybe ModName
mpAs        = forall a. Maybe a
Nothing
                        , mpName :: Ident
mpName      = Located (ImpName PName) -> Maybe (Located ModName) -> Ident
mkModParamName (forall t. MkAnon t => t -> ImpName PName
toImpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located name
nm)
                                                                        forall a. Maybe a
Nothing
                        , mpDoc :: Maybe (Located Text)
mpDoc       = forall a. Maybe a
Nothing
                        , mpRenaming :: ModuleInstance PName
mpRenaming  = forall a. Monoid a => a
mempty
                        }
                      ]
                  )

      TopDecl PName
d : [TopDecl PName]
more ->
        let cont :: [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName]
emit Signature PName
sig' =
              do ([ModuleG name PName]
ms,[TopDecl PName]
ds') <- Signature PName
-> [TopDecl PName]
-> ParseM ([ModuleG name PName], [TopDecl PName])
go Signature PName
sig' [TopDecl PName]
more
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleG name PName]
ms, [TopDecl PName]
emit forall a. [a] -> [a] -> [a]
++ [TopDecl PName]
ds')
        in
        case TopDecl PName
d of

          DImport Located (ImportG (ImpName PName))
i | ImpTop ModName
_ <- forall mname. ImportG mname -> mname
iModule (forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i)
                    , Maybe (ModuleInstanceArgs PName)
Nothing  <- forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i) ->
            [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName
d] (forall {name}.
Located (ImportG (ImpName name))
-> Signature name -> Signature name
addI Located (ImportG (ImpName PName))
i Signature PName
sig)

          DImport Located (ImportG (ImpName PName))
i | Just ModuleInstanceArgs PName
inst <- forall mname. ImportG mname -> Maybe (ModuleInstanceArgs PName)
iInst (forall a. Located a -> a
thing Located (ImportG (ImpName PName))
i) ->
            do [TopDecl PName]
newDs <- Located (ImportG (ImpName PName))
-> ModuleInstanceArgs PName -> ParseM [TopDecl PName]
desugarInstImport Located (ImportG (ImpName PName))
i ModuleInstanceArgs PName
inst
               [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName]
newDs Signature PName
sig

          DParamDecl Range
_ Signature PName
ds' -> [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [] (forall {name}. Signature name -> Signature name -> Signature name
jnSig Signature PName
ds' Signature PName
sig)

          DModule TopLevel (NestedModule PName)
tl | NestedModule ModuleG PName PName
mo <- forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
tl ->
            do [ModuleG PName PName]
ms <- forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod ModuleG PName PName
mo
               [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [ forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
tl { tlValue :: NestedModule PName
tlValue = forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG PName PName
m } | ModuleG PName PName
m <- [ModuleG PName PName]
ms ] Signature PName
sig

          TopDecl PName
_ -> [TopDecl PName]
-> Signature PName
-> ParseM ([ModuleG name PName], [TopDecl PName])
cont [TopDecl PName
d] Signature PName
sig

desugarInstImport ::
  Located (ImportG (ImpName PName)) {- ^ The import -} ->
  ModuleInstanceArgs PName          {- ^ The insantiation -} ->
  ParseM [TopDecl PName]
desugarInstImport :: Located (ImportG (ImpName PName))
-> ModuleInstanceArgs PName -> ParseM [TopDecl PName]
desugarInstImport Located (ImportG (ImpName PName))
i ModuleInstanceArgs PName
inst =
  do [ModuleG PName PName]
ms <- forall name.
MkAnon name =>
ModuleG name PName -> ParseM [ModuleG name PName]
desugarMod
           Module { mName :: LPName
mName = Located (ImportG (ImpName PName))
i { thing :: PName
thing = PName
iname }
                  , mDef :: ModuleDefinition PName
mDef  = forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance
                              (forall mname. ImportG mname -> mname
iModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (ImportG (ImpName PName))
i) ModuleInstanceArgs PName
inst forall name. Ord name => ModuleInstance name
emptyModuleInstance
                  }
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. Located (ImportG (ImpName name)) -> TopDecl name
DImport (forall {mname}. ImportG mname -> ImportG (ImpName PName)
newImp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located (ImportG (ImpName PName))
i) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {name}. ModuleG name name -> TopDecl name
modTop [ModuleG PName PName]
ms)

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

  newImp :: ImportG mname -> ImportG (ImpName PName)
newImp ImportG mname
d = ImportG mname
d { iModule :: ImpName PName
iModule = forall name. name -> ImpName name
ImpNested PName
iname
               , iInst :: Maybe (ModuleInstanceArgs PName)
iInst   = forall a. Maybe a
Nothing
               }

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