cryptol-3.4.0: src/Cryptol/Parser/ParserUtils.hs
-- |
-- Module : Cryptol.Parser.ParserUtils
-- Copyright : (c) 2013-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where
import Data.Char(isAlphaNum, isSpace)
import Data.Maybe(fromMaybe, mapMaybe)
import Data.Bits(testBit,setBit)
import Data.List(foldl')
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard,msum)
import qualified Control.Monad.Fail as Fail
import Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import Text.Read(readMaybe)
import Data.Foldable (for_)
import GHC.Generics (Generic)
import Control.DeepSeq
import Prelude ()
import Prelude.Compat
import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Token(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident( packModName,packIdent,modNameChunks
, identAnonArg, identAnonIfaceMod, identAnonInstImport
, modNameArg, modNameIfaceMod
, mainModName, modNameIsNormal
, modNameToNormalModName
, unpackIdent, isUpperIdent
)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Cryptol.Utils.RecordMap
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString cfg p cs = parse cfg p (T.pack cs)
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse cfg p cs = case unP p cfg eofPos S { sPrevTok = Nothing
, sTokens = toks
, sNextTyParamNum = 0
} of
Left err -> Left err
Right (a,_) -> Right a
where (toks,eofPos) = lexer cfg cs
{- The parser is parameterized by the pozition of the final token. -}
newtype ParseM a =
P { unP :: Config -> Position -> S -> Either ParseError (a,S) }
askConfig :: ParseM Config
askConfig = P \cfg _ s -> Right (cfg, s)
lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP k = P $ \cfg p s ->
case sTokens s of
t : _ | Err e <- tokenType it ->
Left $ HappyErrorMsg (srcRange t) $
[case e of
UnterminatedComment -> "unterminated comment"
UnterminatedString -> "unterminated string"
UnterminatedChar -> "unterminated character"
InvalidString -> "invalid string literal: " ++
T.unpack (tokenText it)
InvalidChar -> "invalid character literal: " ++
T.unpack (tokenText it)
LexicalError -> "unrecognized character: " ++
T.unpack (tokenText it)
MalformedLiteral -> "malformed literal: " ++
T.unpack (tokenText it)
MalformedSelector -> "malformed selector: " ++
T.unpack (tokenText it)
InvalidIndentation c -> "invalid indentation, unmatched " ++
case c of
Sym CurlyR -> "{ ... } "
Sym ParenR -> "( ... )"
Sym BracketR -> "[ ... ]"
_ -> show c -- basically panic
]
where it = thing t
t : more -> unP (k t) cfg p s { sPrevTok = Just t, sTokens = more }
[] -> Left (HappyOutOfTokens (cfgSource cfg) 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 (Show, Generic, NFData)
data S = S { sPrevTok :: Maybe (Located Token)
, sTokens :: [Located Token]
, sNextTyParamNum :: !Int
-- ^ Keep track of the type parameters as they appear in the input
}
ppError :: ParseError -> Doc
ppError (HappyError path ltok)
| Err _ <- tokenType tok =
text "Parse error at" <+>
text path <.> char ':' <.> pp pos <.> comma <+>
pp tok
| White DocStr <- tokenType tok =
"Unexpected documentation (/**) comment at" <+>
text path <.> char ':' <.> pp pos <.> colon $$
indent 2
"Documentation comments need to be followed by something to document."
| otherwise =
text "Parse error at" <+>
text path <.> char ':' <.> pp pos <.> comma $$
indent 2 (text "unexpected:" <+> pp tok)
where
pos = from (srcRange ltok)
tok = thing ltok
ppError (HappyOutOfTokens path pos) =
text "Unexpected end of file at:" <+>
text path <.> char ':' <.> pp pos
ppError (HappyErrorMsg p xs) = text "Parse error at" <+> pp p $$ indent 2 (vcat (map text xs))
ppError (HappyUnexpected path ltok e) =
nest 2 $ vcat $
[ text "Parse error at" <+> text path <.> char ':' <.> pp pos <.> comma ]
++ unexp
++ ["expected:" <+> text e]
where
(unexp,pos) =
case ltok of
Nothing -> ( [] ,start)
Just t -> ( ["unexpected:" <+> text (T.unpack (tokenText (thing t)))]
, from (srcRange t)
)
instance Functor ParseM where
fmap = liftM
instance Applicative ParseM where
pure a = P (\_ _ s -> Right (a,s))
(<*>) = ap
instance Monad ParseM where
return = pure
m >>= k = P (\cfg p s1 -> case unP m cfg p s1 of
Left e -> Left e
Right (a,s2) -> unP (k a) cfg p s2)
instance Fail.MonadFail ParseM where
fail s = panic "[Parser] fail" [s]
happyError :: ParseM a
happyError = P $ \cfg _ s ->
case sPrevTok s of
Just t -> Left (HappyError (cfgSource cfg) t)
Nothing ->
Left (HappyErrorMsg emptyRange ["Parse error at the beginning of the file"])
errorMessage :: Range -> [String] -> ParseM a
errorMessage r xs = P $ \_ _ _ -> Left (HappyErrorMsg r xs)
customError :: String -> Located Token -> ParseM a
customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) [x])
expected :: String -> ParseM a
expected x = P $ \cfg _ s ->
Left (HappyUnexpected (cfgSource cfg) (sPrevTok s) x)
mkModName :: [Text] -> ModName
mkModName = 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 lsig qual =
case qual of
Nothing ->
case thing lsig of
ImpTop t
| modNameIsNormal t -> packIdent (last (modNameChunks t))
| otherwise -> identAnonIfaceMod
$ packIdent
$ last
$ modNameChunks
$ modNameToNormalModName t
ImpNested nm ->
case nm of
UnQual i -> i
Qual _ i -> i
NewName {} -> panic "mkModParamName" ["Unexpected NewName",show lsig]
Just m -> packIdent (last (modNameChunks (thing m)))
-- Note that type variables are not resolved at this point: they are tcons.
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema xs ps t = Forall xs ps t Nothing
getName :: Located Token -> PName
getName l = case thing l of
Token (Ident [] x) _ -> mkUnqual (mkIdent x)
_ -> panic "[Parser] getName" ["not an Ident:", show l]
getNum :: Located Token -> Integer
getNum l = case thing l of
Token (Num x _ _) _ -> x
Token (ChrLit x) _ -> toInteger (fromEnum x)
_ -> panic "[Parser] getNum" ["not a number:", show l]
getChr :: Located Token -> Char
getChr l = case thing l of
Token (ChrLit x) _ -> x
_ -> panic "[Parser] getChr" ["not a char:", show l]
getStr :: Located Token -> String
getStr l = case thing l of
Token (StrLit x) _ -> x
_ -> panic "[Parser] getStr" ["not a string:", show l]
numLit :: Token -> Expr PName
numLit Token { tokenText = txt, tokenType = Num x base digs }
| base == 2 = ELit $ ECNum x (BinLit txt digs)
| base == 8 = ELit $ ECNum x (OctLit txt digs)
| base == 10 = ELit $ ECNum x (DecLit txt)
| base == 16 = ELit $ ECNum x (HexLit txt digs)
numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]
fracLit :: Token -> Expr PName
fracLit tok =
case tokenType tok of
Frac x base
| base == 2 -> ELit $ ECFrac x $ BinFrac $ tokenText tok
| base == 8 -> ELit $ ECFrac x $ OctFrac $ tokenText tok
| base == 10 -> ELit $ ECFrac x $ DecFrac $ tokenText tok
| base == 16 -> ELit $ ECFrac x $ HexFrac $ tokenText tok
_ -> panic "[Parser] fracLit" [ "Invalid fraction", show tok ]
intVal :: Located Token -> ParseM Integer
intVal tok =
case tokenType (thing tok) of
Num x _ _ -> return x
_ -> errorMessage (srcRange tok) ["Expected an integer"]
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity assoc tok qns =
do l <- intVal tok
unless (l >= 1 && l <= 100)
(errorMessage (srcRange tok) ["Fixity levels must be between 1 and 100"])
return (DFixity (Fixity assoc (fromInteger l)) qns)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit loc = case tokenType (thing loc) of
StrLit str -> return loc { thing = str }
_ -> errorMessage (srcRange loc) ["Expected a string literal"]
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType rng ty =
case ty of
TLocated t r -> validDemotedType r t
TRecord {} -> bad "Record types"
TTyApp {} -> bad "Explicit type application"
TTuple {} -> bad "Tuple types"
TFun {} -> bad "Function types"
TSeq {} -> bad "Sequence types"
TBit -> bad "Type bit"
TNum {} -> ok
TChar {} -> ok
TWild -> bad "Wildcard types"
TUser {} -> ok
TParens t mb -> case mb of
Nothing -> validDemotedType rng t
Just _ -> bad "kind annotation"
TInfix{} -> ok
where bad x = errorMessage rng [x ++ " cannot be demoted."]
ok = return $ at rng ty
-- | Input fields are reversed!
mkRecord :: AddLoc b => Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
mkRecord rng f xs =
case res of
Left (nm,(nmRng,_)) -> errorMessage nmRng ["Record has repeated field: " ++ show (pp nm)]
Right r -> pure $ at rng (f r)
where
res = recordFromFieldsErr ys
ys = map (\ (Named (Located r nm) x) -> (nm,(r,x))) (reverse xs)
-- | Input expression are reversed
mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)
mkEApp es@(eLast :| _) =
do f :| xs <- cvtTypeParams eFirst rest
pure (at (eFirst,eLast) $ foldl EApp f xs)
where
eFirst :| rest = NE.reverse 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 e [] = pure (e :| [])
cvtTypeParams e (p : ps) =
case toTypeParam p Nothing of
Nothing -> NE.cons e <$> cvtTypeParams p ps
Just (fs,ss,rng) ->
if checkAppExpr e then
let e' = foldr (flip ESel) (EAppT e fs) ss
e'' = case rCombMaybe (getLoc e) rng of
Just r -> ELocated e' r
Nothing -> e'
in cvtTypeParams e'' ps
else
errorMessage (fromMaybe emptyRange (getLoc e))
[ "Explicit type applications can only be applied to named values."
, "Unexpected: " ++ show (pp 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 e =
case e of
ELocated e' _ -> checkAppExpr e'
EParens e' -> checkAppExpr e'
EVar{} -> True
_ -> 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 e mr =
case e of
ELocated e' rng -> toTypeParam e' (rCombMaybe mr (Just rng))
ETypeVal t -> toTypeParam' t mr
ESel e' s -> ( \(fs,ss,r) -> (fs,s:ss,r) ) <$> toTypeParam e' mr
_ -> Nothing
toTypeParam' t mr =
case t of
TLocated t' rng -> toTypeParam' t' (rCombMaybe mr (Just rng))
TTyApp fs -> Just (map mkTypeInst fs, [], mr)
_ -> Nothing
unOp :: Expr PName -> Expr PName -> Expr PName
unOp f x = at (f,x) $ EApp f x
-- Use defaultFixity as a placeholder, it will be fixed during renaming.
binOp :: Expr PName -> Located PName -> Expr PName -> Expr PName
binOp x f y = at (x,y) $ EInfix x f defaultFixity 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 r e1 e2 e3 =
case (asETyped e1, asETyped =<< e2, asETyped e3) of
(Just (e1', t), Nothing, Nothing) -> eFromToType r e1' e2 e3 (Just t)
(Nothing, Just (e2', t), Nothing) -> eFromToType r e1 (Just e2') e3 (Just t)
(Nothing, Nothing, Just (e3', t)) -> eFromToType r e1 e2 e3' (Just t)
(Nothing, Nothing, Nothing) -> eFromToType r e1 e2 e3 Nothing
_ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."]
eFromToBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToBy r e1 e2 e3 isStrictBound =
case (asETyped e1, asETyped e2, asETyped e3) of
(Just (e1', t), Nothing, Nothing) -> eFromToByTyped r e1' e2 e3 (Just t) isStrictBound
(Nothing, Just (e2', t), Nothing) -> eFromToByTyped r e1 e2' e3 (Just t) isStrictBound
(Nothing, Nothing, Just (e3', t)) -> eFromToByTyped r e1 e2 e3' (Just t) isStrictBound
(Nothing, Nothing, Nothing) -> eFromToByTyped r e1 e2 e3 Nothing isStrictBound
_ -> errorMessage r ["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 r e1 e2 e3 t isStrictBound =
EFromToBy isStrictBound
<$> exprToNumT r e1
<*> exprToNumT r e2
<*> exprToNumT r e3
<*> pure t
eFromToDownBy ::
Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToDownBy r e1 e2 e3 isStrictBound =
case (asETyped e1, asETyped e2, asETyped e3) of
(Just (e1', t), Nothing, Nothing) -> eFromToDownByTyped r e1' e2 e3 (Just t) isStrictBound
(Nothing, Just (e2', t), Nothing) -> eFromToDownByTyped r e1 e2' e3 (Just t) isStrictBound
(Nothing, Nothing, Just (e3', t)) -> eFromToDownByTyped r e1 e2 e3' (Just t) isStrictBound
(Nothing, Nothing, Nothing) -> eFromToDownByTyped r e1 e2 e3 Nothing isStrictBound
_ -> errorMessage r ["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 r e1 e2 e3 t isStrictBound =
EFromToDownBy isStrictBound
<$> exprToNumT r e1
<*> exprToNumT r e2
<*> exprToNumT r e3
<*> pure t
asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped (ELocated e _) = asETyped e
asETyped (ETyped e t) = Just (e, t)
asETyped _ = Nothing
eFromToType ::
Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType r e1 e2 e3 t =
EFromTo <$> exprToNumT r e1
<*> mapM (exprToNumT r) e2
<*> exprToNumT r e3
<*> pure t
eFromToLessThan ::
Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan r e1 e2 =
case asETyped e2 of
Just _ -> errorMessage r ["The exclusive upper bound of an enumeration may not have a type annotation."]
Nothing ->
case asETyped e1 of
Nothing -> eFromToLessThanType r e1 e2 Nothing
Just (e1',t) -> eFromToLessThanType r e1' e2 (Just t)
eFromToLessThanType ::
Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToLessThanType r e1 e2 t =
EFromToLessThan
<$> exprToNumT r e1
<*> exprToNumT r e2
<*> pure t
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT r expr =
case translateExprToNumT r expr of
Just t -> return t
Nothing -> bad
where
bad = errorMessage (fromMaybe r (getLoc expr))
[ "The boundaries of .. sequences should be valid numeric types."
, "The expression `" ++ show (pp expr) ++ "` 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 ~(Just r) ts = TLocated (TTyApp (map toField ts)) r
where noName = Located { srcRange = r, thing = mkIdent (T.pack "") }
toField t = Named { name = noName, value = t }
exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl mbDoc e d = Decl TopLevel { tlExport = e
, tlDoc = mbDoc
, tlValue = d }
exportNewtype :: ExportType -> Maybe (Located Text) -> Newtype PName ->
TopDecl PName
exportNewtype e d n = TDNewtype TopLevel { tlExport = e
, tlDoc = d
, tlValue = n }
exportEnum ::
ExportType -> Maybe (Located Text) -> EnumDecl PName -> TopDecl PName
exportEnum e d n = TDEnum TopLevel { tlExport = e
, tlDoc = d
, tlValue = n }
exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule mbDoc m = DModule TopLevel { tlExport = Public
, tlDoc = mbDoc
, tlValue = m }
mkParFun :: Maybe (Located Text) ->
Located PName ->
Schema PName ->
ParamDecl PName
mkParFun mbDoc n s = DParameterFun ParameterFun { pfName = n
, pfSchema = s
, pfDoc = mbDoc
, pfFixity = Nothing
}
mkParType :: Maybe (Located Text) ->
Located PName ->
Located Kind ->
ParseM (ParamDecl PName)
mkParType mbDoc n k =
do num <- P $ \_ _ s -> let nu = sNextTyParamNum s
in Right (nu, s { sNextTyParamNum = nu + 1 })
return (DParameterType
ParameterType { ptName = n
, ptKind = thing k
, ptDoc = mbDoc
, ptFixity = Nothing
, ptNumber = num
})
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport e = map change
where
change decl =
case decl of
Decl d -> Decl d { tlExport = e }
DPrimType t -> DPrimType t { tlExport = e }
TDNewtype n -> TDNewtype n { tlExport = e }
TDEnum n -> TDEnum n { tlExport = e }
DModule m -> DModule m { tlExport = e }
DModParam {} -> decl
Include{} -> decl
DImport{} -> decl
DParamDecl{} -> decl
DInterfaceConstraint {} -> decl
addDeclDocstring :: Located Text -> TopDecl name -> ParseM (TopDecl name)
addDeclDocstring doc decl =
case decl of
Decl d -> Decl <$> topLevel d
DPrimType t -> DPrimType <$> topLevel t
TDNewtype n -> TDNewtype <$> topLevel n
TDEnum n -> TDEnum <$> topLevel n
DModule m -> DModule <$> topLevel m
DModParam p -> pure (DModParam p { mpDoc = Just doc })
Include _ -> failure "Docstring on include"
DImport i -> DImport <$> traverse imp i
DInterfaceConstraint Nothing x -> pure (DInterfaceConstraint (Just doc) x)
DInterfaceConstraint Just{} _ -> failure "Overlapping docstring"
DParamDecl{} -> failure "Docstring on parameter declarations"
where
failure e = errorMessage (fromMaybe emptyRange (getLoc decl)) [e]
imp i =
case iDoc i of
Nothing -> pure i { iDoc = Just doc }
Just{} -> failure "Overlapping docstring"
topLevel x =
case tlDoc x of
Just _ -> failure "Overlapping docstring"
Nothing -> pure x { tlDoc = Just doc }
privateDocedDecl :: Located Text -> [TopDecl PName] -> ParseM [TopDecl PName]
privateDocedDecl doc (decl:decls) = fmap (: decls) (addDeclDocstring doc decl)
privateDocedDecl doc [] = errorMessage (srcRange doc) ["Docstring on empty private section"]
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst x | nullIdent (thing (name x)) = PosInst (value x)
| otherwise = NamedInst x
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam Located { srcRange = rng, thing = n } k
| n == widthIdent = errorMessage rng ["`width` is not a valid type parameter name."]
| otherwise = return (TParam (mkUnqual n) k (Just rng))
mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkTySyn thead tdef =
do (nm,params) <- typeToDecl thead
pure (DType (TySyn nm Nothing params tdef))
mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkPropSyn thead tdef =
do (nm,params) <- typeToDecl thead
ps <- thing <$> mkProp tdef
pure (DProp (PropSyn nm Nothing params ps))
mkNewtype ::
Type PName ->
Located (RecordMap Ident (Range, Type PName)) ->
ParseM (Newtype PName)
mkNewtype thead def =
do (nm,params) <- typeToDecl thead
pure (Newtype nm params (thing nm) (thing def))
mkEnumDecl ::
Type PName ->
[ TopLevel (EnumCon PName) ] {- ^ Reversed -} ->
ParseM (EnumDecl PName)
mkEnumDecl thead def =
do (nm,params) <- typeToDecl thead
mapM_ reportRepeated
(Map.toList (Map.fromListWith (++) [ (thing k,[srcRange k])
| k <- map (ecName . tlValue) def ]))
pure EnumDecl
{ eName = nm
, eParams = params
, eCons = reverse def
}
where
reportRepeated (i,xs) =
case xs of
l : ls@(_ : _) ->
errorMessage l
( ("Multiple declarations for " ++ show (backticks (pp i)))
: [ "Other declaration: " ++ show (pp x) | x <- ls ]
)
_ -> pure ()
mkConDecl ::
Maybe (Located Text) -> ExportType ->
Type PName -> ParseM (TopLevel (EnumCon PName))
mkConDecl mbDoc expT ty =
do con <- go Nothing ty
pure TopLevel { tlExport = expT, tlDoc = mbDoc, tlValue = con }
where
go mbLoc t =
case t of
TLocated t1 r -> go (Just r) t1
TUser n ts ->
case thing n of
UnQual i
| isUpperIdent i ->
pure EnumCon { ecName = Located (srcRange n) (UnQual i)
, ecFields = ts
}
| otherwise ->
errorMessage (getL mbLoc)
[ "Malformed constructor declaration."
, "The constructor name should start with a capital letter."
]
_ -> errorMessage (getL mbLoc)
[ "Malformed constructor declaration."
, "The constructor name may not be qualified."
]
_ -> errorMessage (getL mbLoc) [ "Malformed constructor declaration." ]
getL mb =
case mb of
Just r -> r
Nothing -> panic "mkConDecl" ["Missing type location"]
typeToDecl :: Type PName -> ParseM (Located PName, [TParam PName])
typeToDecl ty0 =
case ty0 of
TLocated ty loc -> goD loc ty
_ -> panic "typeToDecl" ["Type location is missing."]
where
bad loc = errorMessage loc ["Invalid type declaration"]
badP loc = errorMessage loc ["Invalid declaration parameter"]
goN loc n =
case n of
UnQual {} -> pure ()
_ -> errorMessage loc ["Invalid declaration name"]
goP loc ty =
case ty of
TLocated ty1 loc1 -> goP loc1 ty1
TUser f [] ->
do goN (srcRange f) (thing f)
pure TParam { tpName = thing f, tpKind = Nothing, tpRange = Just loc }
TParens t mb ->
case mb of
Nothing -> badP loc
Just k ->
do p <- goP loc t
case tpKind p of
Nothing -> pure p { tpKind = Just k }
Just {} -> badP loc
TInfix {} -> badP loc
TUser {} -> badP loc
TFun {} -> badP loc
TSeq {} -> badP loc
TBit {} -> badP loc
TNum {} -> badP loc
TChar {} -> badP loc
TRecord {} -> badP loc
TWild {} -> badP loc
TTyApp {} -> badP loc
TTuple {} -> badP loc
goD loc ty =
case ty of
TLocated ty1 loc1 -> goD loc1 ty1
TUser f ts ->
do goN (srcRange f) (thing f)
ps <- mapM (goP loc) ts
pure (f,ps)
TInfix l f _ r ->
do goN (srcRange f) (thing f)
a <- goP loc l
b <- goP loc r
pure (f,[a,b])
TFun {} -> bad loc
TSeq {} -> bad loc
TBit {} -> bad loc
TNum {} -> bad loc
TChar {} -> bad loc
TRecord {} -> bad loc
TWild {} -> bad loc
TTyApp {} -> bad loc
TTuple {} -> bad loc
TParens {} -> bad loc
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm rng k p
| k == 0 = return (False, p)
| k == 1 = return (True, p)
| otherwise = errorMessage rng ["Invalid polynomial coefficient"]
mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly rng terms
| w <= toInteger (maxBound :: Int) = mk 0 (map fromInteger bits)
| otherwise = errorMessage rng ["Polynomial literal too large: " ++ show w]
where
w = case terms of
[] -> 0
_ -> 1 + maximum (map snd terms)
bits = [ n | (True,n) <- terms ]
mk :: Integer -> [Int] -> ParseM (Expr PName)
mk res [] = return $ ELit $ ECNum res (PolyLit (fromInteger w :: Int))
mk res (n : ns)
| testBit res n = errorMessage rng
["Polynomial contains multiple terms with exponent " ++ show n]
| otherwise = mk (setBit res n) ns
-- NOTE: The list of patterns is reversed!
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty f ps e = at (f,e) $
DBind Bind { bName = f
, bParams = PatternParams (reverse ps)
, bDef = at e (Located emptyRange (exprDef e))
, bSignature = Nothing
, bPragmas = [PragmaProperty]
, bMono = False
, bInfix = False
, bFixity = Nothing
, bDoc = Nothing
, bExport = Public
}
-- NOTE: The lists of patterns are reversed!
mkIndexedDecl ::
LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl f (ps, ixs) e =
DBind Bind { bName = f
, bParams = PatternParams (reverse ps)
, bDef = at e (Located emptyRange (exprDef rhs))
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = False
, bFixity = Nothing
, bDoc = Nothing
, bExport = Public
}
where
rhs :: Expr PName
rhs = mkGenerate (reverse ixs) e
-- NOTE: The lists of patterns are reversed!
mkPropGuardsDecl ::
LPName ->
([Pattern PName], [Pattern PName]) ->
[PropGuardCase PName] ->
ParseM (Decl PName)
mkPropGuardsDecl f (ps, ixs) guards =
do unless (null ixs) $
errorMessage (srcRange f)
["Indexed sequence definitions may not use constraint guards"]
let gs = reverse guards
pure $
DBind Bind { bName = f
, bParams = PatternParams (reverse ps)
, bDef = Located (srcRange f) (DImpl (DPropGuards gs))
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = False
, bFixity = Nothing
, bDoc = Nothing
, bExport = Public
}
mkConstantPropGuardsDecl ::
LPName -> [PropGuardCase PName] -> ParseM (Decl PName)
mkConstantPropGuardsDecl f guards =
mkPropGuardsDecl f ([],[]) guards
-- NOTE: The lists of patterns are reversed!
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr (ps, ixs) body
| null ps = mkGenerate (reverse ixs) body
| otherwise = EFun emptyFunDesc (reverse ps) (mkGenerate (reverse ixs) body)
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate pats body =
foldr (\pat e -> EGenerate (EFun emptyFunDesc [pat] e)) body pats
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf ifThens theElse = foldr addIfThen theElse ifThens
where
addIfThen (cond, doexpr) elseExpr = EIf cond doexpr elseExpr
mkPVar :: Located PName -> Pattern PName
mkPVar p =
case thing p of
UnQual i | isInfixIdent i || not (isUpperIdent i) -> PVar p
_ -> PCon p []
mkIPat :: Pattern PName -> ParseM (Pattern PName)
mkIPat pat =
case pat of
PVar {} -> pure pat
PWild -> pure pat
PTuple ps -> PTuple <$> traverse mkIPat ps
PRecord rp -> PRecord <$> traverseRecordMap upd rp
where upd _ (x,y) = (,) x <$> mkIPat y
PList ps -> PList <$> traverse mkIPat ps
PTyped p t -> (`PTyped` t) <$> mkIPat p
PSplit p1 p2 -> PSplit <$> mkIPat p1 <*> mkIPat p2
PLocated p r -> (`PLocated` r) <$> mkIPat p
PCon n ps ->
case ps of
[] | UnQual {} <- thing n -> pure (PVar n)
_ -> errorMessage (srcRange n)
[ "Unexpected constructor pattern."
, "Constructors patterns may be used only in `case` expressions."
]
mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl = mkNoImplDecl DPrim
mkForeignDecl ::
Maybe (Located Text) -> Maybe LPName -> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl mbDoc mbCC nm ty =
do let txt = unpackIdent (getIdent (thing nm))
fgn <- case mbCC of
Nothing -> pure ForeignC
Just cc ->
case thing cc of
UnQual i
| tx == "c" -> pure ForeignC
| tx == "abstract" -> pure ForeignAbstract
where tx = identText i
_ -> errorMessage (srcRange cc)
[ "Invalid calling convention."
, "We support `c` and `abstract` at present."
]
unless (all isOk txt)
(errorMessage (srcRange nm)
[ "`" ++ txt ++ "` is not a valid foreign name."
, "The name should contain only alpha-numeric characters or '_'."
])
-- We do allow optional cryptol implementations of foreign functions, these
-- will be merged with this binding in the NoPat pass. In the parser they
-- are just treated as a completely separate (non-foreign) binding with the
-- same name.
pure (mkNoImplDecl (DForeign fgn Nothing) mbDoc nm ty)
where
isOk c = c == '_' || isAlphaNum 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 def mbDoc ln sig =
[ exportDecl Nothing Public
$ DBind Bind { bName = ln
, bParams = noParams
, bDef = at sig (Located emptyRange def)
, bSignature = Nothing
, bPragmas = []
, bMono = False
, bInfix = isInfixIdent (getIdent (thing ln))
, bFixity = Nothing
, bDoc = Nothing
, bExport = Public
}
, exportDecl mbDoc Public
$ DSignature [ln] sig
]
mkPrimTypeDecl ::
Maybe (Located Text) ->
Schema PName ->
Located Kind ->
ParseM [TopDecl PName]
mkPrimTypeDecl mbDoc (Forall as qs st ~(Just schema_rng)) finK =
case splitT st of
Just (n,xs) ->
do vs <- mapM tpK as
unless (distinct (map fst vs)) $
errorMessage schema_rng ["Repeated parameters."]
let kindMap = Map.fromList vs
lkp v = case Map.lookup (thing v) kindMap of
Just (k,tp) -> pure (k,tp)
Nothing ->
errorMessage
(srcRange v)
["Undefined parameter: " ++ show (pp (thing v))]
(as',ins) <- unzip <$> mapM lkp xs
unless (length vs == length xs) $
errorMessage schema_rng ["All parameters should appear in the type."]
let ki = finK { thing = foldr KFun (thing finK) ins }
pure [ DPrimType TopLevel
{ tlExport = Public
, tlDoc = mbDoc
, tlValue = PrimType { primTName = n
, primTKind = ki
, primTCts = (as',qs)
, primTFixity = Nothing
}
}
]
Nothing -> errorMessage schema_rng ["Invalid primitive signature"]
where
splitT ty = case ty of
TLocated t _ -> splitT t
TUser n ts -> mkT n ts
TInfix t1 n _ t2 -> mkT n [t1,t2]
_ -> Nothing
mkT n ts = do ts1 <- mapM isVar ts
guard (distinct (map thing ts1))
pure (n,ts1)
isVar ty = case ty of
TLocated t _ -> isVar t
TUser n [] -> Just n
_ -> Nothing
-- inefficient, but the lists should be small
distinct xs = case xs of
[] -> True
x : ys -> not (x `elem` ys) && distinct ys
tpK tp = case tpKind tp of
Just k -> pure (tpName tp, (tp,k))
Nothing ->
case tpRange tp of
Just r -> errorMessage r ["Parameters need a kind annotation"]
Nothing -> panic "mkPrimTypeDecl"
[ "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 ltxt = ltxt { thing = docStr }
where
docStr = T.unlines
$ handlePrefixes
$ T.lines
$ T.dropWhileEnd commentChar
$ thing ltxt
commentChar :: Char -> Bool
commentChar x = x `elem` ("/*" :: String) || isSpace x
-- Prefix dropping with a special case for the first line and common
-- prefix dropping for the following lines. The first line and following
-- lines are treated independently
handlePrefixes :: [Text] -> [Text]
handlePrefixes [] = []
handlePrefixes (l:ls)
| T.all commentChar l = ls'
| otherwise = T.dropWhile commentChar l : ls'
where ls' = dropPrefix ls
dropPrefix :: [Text] -> [Text]
dropPrefix ts =
case startDropPrefixChar ts of
Nothing -> ts -- done dropping
Just ts' -> dropPrefix ts' -- keep dropping
-- At the beginning of a prefix stripping operation we check the
-- first character of the first line. If that first character is
-- droppable we use it as the prefix to check for, otherwise we
-- continue searching for whitespace. Return Nothing if there
-- was no prefix to drop.
startDropPrefixChar :: [Text] -> Maybe [Text]
startDropPrefixChar [] = Nothing
startDropPrefixChar (l:ls) =
case T.uncons l of
Nothing -> (l:) <$> searchWhitePrefixChar ls
Just (c, l')
| c == '*' || isSpace c -> (l':) <$> checkPrefixChar c ls
| otherwise -> Nothing
-- So far we've only seen empty lines, so we accept empty
-- lines and lines starting with whitespace.
searchWhitePrefixChar :: [Text] -> Maybe [Text]
searchWhitePrefixChar [] = Just []
searchWhitePrefixChar (l:ls) =
case T.uncons l of
Nothing -> (l:) <$> searchWhitePrefixChar ls
Just (c, l')
| isSpace c -> (l':) <$> checkPrefixChar c ls
| otherwise -> Nothing
-- So far we've seen a non-empty line and we know what character
-- we're looking for. If that character is whitespace then we also
-- will accept empty lines as matching the prefix
checkPrefixChar :: Char -> [Text] -> Maybe [Text]
checkPrefixChar _ [] = Just []
checkPrefixChar p (l:ls) =
case T.uncons l of
Nothing
| isSpace p -> (l:) <$> checkPrefixChar p ls
Just (c,l')
| c == p -> (l':) <$> checkPrefixChar p ls
_ -> Nothing
distrLoc :: Located [a] -> [Located a]
distrLoc x = [ Located { srcRange = r, thing = a } | a <- thing x ]
where r = srcRange x
mkPropGuards :: Type PName -> ParseM [Located (Prop PName)]
mkPropGuards ty =
do lp <- mkProp ty
pure [ lp { thing = p } | p <- thing lp ]
mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp ty =
case ty of
TLocated t r -> Located r `fmap` props r t
_ -> panic "Parser" [ "Invalid type given to mkProp"
, "expected a location"
, show ty ]
where
props r t =
case t of
TInfix{} -> return [CType t]
TUser{} -> return [CType t]
TTuple ts -> concat `fmap` mapM (props r) ts
TParens t' mb -> case mb of
Nothing -> props r t'
Just _ -> err
TLocated t' r' -> props r' t'
TFun{} -> err
TSeq{} -> err
TBit{} -> err
TNum{} -> err
TChar{} -> err
TWild -> err
TRecord{} -> err
TTyApp{} -> err
where
err = errorMessage r ["Invalid constraint"]
-- | Make an ordinary module
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule nm ds = Module { mName = nm
, mDef = NormalModule ds
, mInScope = mempty
, mDocTop = Nothing
}
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested m =
case modNameChunks (thing nm) of
[c] -> pure (NestedModule m { mName = nm { thing = mkUnqual (packIdent c)}})
_ -> errorMessage r
["Nested modules names should be a simple identifier."]
where
nm = mName m
r = srcRange nm
mkSigDecl :: Maybe (Located Text) -> (Located PName,Signature PName) -> TopDecl PName
mkSigDecl doc (nm,sig) =
DModule
TopLevel { tlExport = Public
, tlDoc = doc
, tlValue = NestedModule
Module { mName = nm
, mDef = InterfaceModule sig
, mInScope = mempty
, mDocTop = Nothing
}
}
mkInterfaceConstraint ::
Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint mbDoc ty =
do ps <- mkProp ty
pure [DInterfaceConstraint mbDoc ps]
mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls ds = DParamDecl loc (mkInterface' [] ds)
where loc = rCombs (mapMaybe getLoc ds)
onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports = mapM_ check
where
check i =
case iInst (thing i) of
Nothing -> pure ()
Just _ ->
errorMessage (srcRange i)
[ "Functor instantiations are not supported in this context."
, "The imported entity needs to be just the name of a module."
, "A workaround would be to do the instantion in the outer context."
]
mkInterface' :: [Located (ImportG (ImpName PName))] ->
[ParamDecl PName] -> Signature PName
mkInterface' is =
foldl' add
Signature { sigImports = is
, sigTypeParams = []
, sigDecls = []
, sigConstraints = []
, sigFunParams = []
}
where
add s d =
case d of
DParameterType pt -> s { sigTypeParams = pt : sigTypeParams s }
DParameterConstraint ps -> s { sigConstraints = pcProps ps ++ sigConstraints s }
DParameterDecl pd -> s { sigDecls = pd : sigDecls s }
DParameterFun pf -> s { sigFunParams = pf : sigFunParams s }
mkInterface :: [Located (ImportG (ImpName PName))] ->
[ParamDecl PName] -> ParseM (Signature PName)
mkInterface is ps =
do onlySimpleImports is
pure (mkInterface' is ps)
mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn mbDoc d =
case d of
DLocated d1 _ -> mkIfacePropSyn mbDoc d1
DType ts -> DParameterDecl (SigTySyn ts mbDoc)
DProp ps -> DParameterDecl (SigPropSyn ps mbDoc)
_ -> panic "mkIfacePropSyn" [ "Unexpected declaration", show (pp d) ]
-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule ds =
do for_ ds \case
DParamDecl l _ -> mainParamError l
DModParam p -> mainParamError (srcRange (mpSignature p))
DInterfaceConstraint _ ps -> mainParamError (srcRange ps)
_ -> pure ()
src <- cfgSource <$> askConfig
mkTopMods Nothing $
mkModule Located
{ srcRange = emptyRange
, thing = mainModName src
}
ds
where
mainParamError l = errorMessage l
["Unnamed module cannot be parameterized"]
-- | Make a module which defines a functor instance.
mkModuleInstanceAnon :: Located ModName ->
Located (ImpName PName) ->
[TopDecl PName] ->
Module PName
mkModuleInstanceAnon nm fun ds =
Module { mName = nm
, mDef = FunctorInstance fun (DefaultInstAnonArg ds) mempty
, mInScope = mempty
, mDocTop = Nothing
}
mkModuleInstance ::
Located ModName ->
Located (ImpName PName) ->
ModuleInstanceArgs PName ->
Module PName
mkModuleInstance m f as =
Module { mName = m
, mDef = FunctorInstance f as emptyModuleInstance
, mInScope = mempty
, mDocTop = Nothing
}
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField h ls e) =
case (h,ls) of
(UpdSet, [l]) | RecordSel i Nothing <- thing l ->
pure Named { name = l { thing = i }, value = e }
_ -> errorMessage (srcRange lab)
["Invalid record field. Perhaps you meant to update a record?"]
where
-- The list of field updates in an UpdField should always be non-empty.
lab = case ls of
lab':_ -> lab'
[] -> panic "ufToNamed" ["UpdField with empty labels"]
-- | The returned list of 'Selector's will be non-empty.
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath e0 = reverse <$> go noLoc e0
where
noLoc = panic "selExprToSels" ["Missing location?"]
go loc expr =
case expr of
ELocated e1 r -> go r e1
ESel e2 s ->
do ls <- go loc e2
let l =
case ls of
l':_ -> l'
[] -> panic "exprToFieldPath" ["empty list of selectors"]
let rng = loc { from = to (srcRange l) }
pure (Located { thing = s, srcRange = rng } : ls)
EVar (UnQual l) ->
pure [ Located { thing = RecordSel l Nothing, srcRange = loc } ]
ELit (ECNum n (DecLit {})) ->
pure [ Located { thing = TupleSel (fromInteger n) Nothing
, srcRange = loc } ]
ELit (ECFrac _ (DecFrac txt))
| (as,bs') <- T.break (== '.') txt
, Just a <- readMaybe (T.unpack as)
, Just (_,bs) <- T.uncons bs'
, Just b <- readMaybe (T.unpack bs)
, let fromP = from loc
, let midP = advanceColBy (T.length as + 1) fromP ->
-- these are backward because we reverse above
pure [ Located { thing = TupleSel b Nothing
, srcRange = loc { from = midP }
}
, Located { thing = TupleSel a Nothing
, srcRange = loc { to = midP }
}
]
_ -> errorMessage loc ["Invalid label in record update."]
mkSelector :: Token -> Selector
mkSelector tok =
case tokenType tok of
Selector (TupleSelectorTok n) -> TupleSel n Nothing
Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing
_ -> panic "mkSelector" [ "Unexpected selector token", show tok ]
mkBacktickImport ::
Range ->
Located (ImpName PName) ->
Maybe (Located ModName) ->
Maybe (Located ImportSpec) ->
Maybe (Located Text) ->
ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport loc impName mbAs mbImportSpec =
mkImport loc impName (Just inst) mbAs mbImportSpec Nothing
where
inst = DefaultInstArg (fmap (const AddParams) impName)
mkImport ::
Range ->
Located (ImpName PName) ->
Maybe (ModuleInstanceArgs PName) ->
Maybe (Located ModName) ->
Maybe (Located ImportSpec) ->
Maybe (Located [Decl PName]) ->
Maybe (Located Text) ->
ParseM (Located (ImportG (ImpName PName)))
mkImport loc impName optInst mbAs mbImportSpec optImportWhere doc =
do i <- getInst
let end = fromMaybe (srcRange impName)
$ msum [ srcRange <$> optImportWhere
, srcRange <$> mbImportSpec
, srcRange <$> mbAs
]
pure Located { srcRange = rComb loc end
, thing = Import
{ iModule = impName
, iAs = thing <$> mbAs
, iSpec = thing <$> mbImportSpec
, iInst = i
, iDoc = doc
}
}
where
getInst =
case (optInst,optImportWhere) of
(Just _, Just _) ->
errorMessage loc [ "Invalid instantiating import."
, "Import should have at most one of:"
, " * { } instantiation, or"
, " * where instantiation"
]
(Just a, Nothing) -> pure (Just a)
(Nothing, Just a) ->
pure (Just (DefaultInstAnonArg (map instTop (thing a))))
where
instTop d = Decl TopLevel
{ tlExport = Public
, tlDoc = Nothing
, tlValue = d
}
(Nothing, Nothing) -> pure Nothing
mkTopMods :: Maybe (Located Text) -> Module PName -> ParseM [Module PName]
mkTopMods doc m =
do (m', ms) <- desugarMod m { mDocTop = doc }
pure (ms ++ [m'])
mkTopSig :: Maybe (Located Text) -> Located ModName -> Signature PName -> [Module PName]
mkTopSig doc nm sig =
[ Module { mName = nm
, mDef = InterfaceModule sig
, mInScope = mempty
, mDocTop = doc
}
]
class MkAnon t where
mkAnon :: AnonThing -> t -> t
toImpName :: t -> ImpName PName
data AnonThing = AnonArg Int Int
-- ^ The ints are line, column used for disambiguation
| AnonIfaceMod
instance MkAnon ModName where
mkAnon what = case what of
AnonArg l c -> modNameArg l c
AnonIfaceMod -> modNameIfaceMod
toImpName = ImpTop
instance MkAnon PName where
mkAnon what = mkUnqual
. case what of
AnonArg l c -> const (identAnonArg l c)
AnonIfaceMod -> identAnonIfaceMod
. getIdent
toImpName = ImpNested
-- | Desugar a module returning first the updated original module and a
-- list of any new modules generated by desugaring.
desugarMod :: MkAnon name => ModuleG name PName -> ParseM (ModuleG name PName, [ModuleG name PName])
desugarMod mo =
case mDef mo of
FunctorInstance f as _ | DefaultInstAnonArg lds <- as ->
do (ms,lds') <- desugarTopDs (mName mo) lds
case ms of
m : _ | InterfaceModule si <- mDef m
, l : _ <- map (srcRange . ptName) (sigTypeParams si) ++
map (srcRange . pfName) (sigFunParams si) ++
[ srcRange (mName mo) ] ->
errorMessage l
[ "Instantiation of a parameterized module may not itself be "
++ "parameterized" ]
_ -> pure ()
let i = mkAnon (AnonArg (line pos) (col pos)) (thing (mName mo))
pos = from (srcRange nm)
nm = Located { srcRange = srcRange (mName mo), thing = i }
as' = DefaultInstArg (ModuleArg . toImpName <$> nm)
pure ( mo { mDef = FunctorInstance f as' mempty }
, [ Module
{ mName = nm
, mDef = NormalModule lds'
, mInScope = mempty
, mDocTop = Nothing
}]
)
NormalModule ds ->
do (newMs, newDs) <- desugarTopDs (mName mo) ds
pure (mo {mDef = NormalModule newDs }, newMs)
_ -> pure (mo, [])
desugarTopDs ::
MkAnon name =>
Located name ->
[TopDecl PName] ->
ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs ownerName = go emptySig
where
isEmpty s =
null (sigTypeParams s) && null (sigConstraints s) && null (sigFunParams s)
emptySig = Signature
{ sigImports = []
, sigTypeParams = []
, sigDecls = []
, sigConstraints = []
, sigFunParams = []
}
jnSig s1 s2 = Signature { sigImports = j sigImports
, sigTypeParams = j sigTypeParams
, sigDecls = j sigDecls
, sigConstraints = j sigConstraints
, sigFunParams = j sigFunParams
}
where
j f = f s1 ++ f s2
addI i s = s { sigImports = i : sigImports s }
go sig ds =
case ds of
[]
| isEmpty sig -> pure ([],[])
| otherwise ->
do let nm = mkAnon AnonIfaceMod <$> ownerName
pure ( [ Module { mName = nm
, mDef = InterfaceModule sig
, mInScope = mempty
, mDocTop = Nothing
}
]
, [ DModParam
ModParam
{ mpSignature = toImpName <$> nm
, mpAs = Nothing
, mpName = mkModParamName (toImpName <$> nm)
Nothing
, mpDoc = Nothing
, mpRenaming = mempty
}
]
)
d : more ->
let cont emit sig' =
do (ms,ds') <- go sig' more
pure (ms, emit ++ ds')
in
case d of
DImport i
| ImpTop _ <- thing (iModule (thing i))
, Nothing <- iInst (thing i) ->
cont [d] (addI i sig)
DImport i
| Just inst <- iInst (thing i) ->
do newDs <- desugarInstImport i inst
cont newDs sig
DParamDecl _ ds' -> cont [] (jnSig ds' sig)
DModule tl | NestedModule mo <- tlValue tl ->
do (mo', ms) <- desugarMod mo
cont ([ DModule TopLevel
{ tlExport = tlExport tl
, tlValue = NestedModule m
, tlDoc = Nothing -- generated modules have no docstrings
}
| m <- ms] ++ [DModule tl { tlValue = NestedModule mo' }])
sig
_ -> cont [d] sig
desugarInstImport ::
Located (ImportG (ImpName PName)) {- ^ The import -} ->
ModuleInstanceArgs PName {- ^ The insantiation -} ->
ParseM [TopDecl PName]
desugarInstImport i inst =
do (m, ms) <- desugarMod
Module { mName = iname
, mDef = FunctorInstance
origMod inst emptyModuleInstance
, mInScope = mempty
, mDocTop = Nothing
}
pure (DImport (newImp <$> i) : map modTop (ms ++ [m]))
where
origMod = iModule (thing i)
iname = Located {
thing =mkUnqual
$ let pos = from (srcRange i)
in identAnonInstImport (line pos) (col pos),
srcRange = srcRange origMod
}
newImp d = d { iModule = ImpNested <$> iname
, iInst = Nothing
}
modTop m = DModule TopLevel
{ tlExport = Private
, tlDoc = Nothing
, tlValue = NestedModule m
}