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

{-# LANGUAGE Safe #-}

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

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

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat


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


parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString 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) }


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 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 = thing <$> 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     = thing <$> 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

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 n of
          UnQual i
            | isUpperIdent i ->
              pure EnumCon { ecName = Located (getL mbLoc) (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 loc f
           pure TParam { tpName = 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 loc f
           ps <- mapM (goP loc) ts
           pure (Located { thing = f, srcRange = loc },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     = 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     = 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     = 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) -> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl mbDoc nm ty =
  do let txt = unpackIdent (getIdent (thing nm))
     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 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    = []
                 , 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 schema_rng 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 r ty = case ty of
                  TLocated t r1 -> splitT r1 t
                  TUser n ts -> mkT r Located { srcRange = r, thing = n } ts
                  TInfix t1 n _ t2  -> mkT r n [t1,t2]
                  _ -> Nothing

  mkT r n ts = do ts1 <- mapM (isVar r) ts
                  guard (distinct (map thing ts1))
                  pure (n,ts1)

  isVar r ty = case ty of
                 TLocated t r1  -> isVar r1 t
                 TUser n []     -> Just Located { srcRange = r, thing = 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
         $ dropPrefix
         $ trimFront
         $ T.lines
         $ T.dropWhileEnd commentChar
         $ thing ltxt

  commentChar :: Char -> Bool
  commentChar x = x `elem` ("/* \r\n\t" :: String)

  prefixDroppable x = x `elem` ("* \r\n\t" :: String)

  whitespaceChar :: Char -> Bool
  whitespaceChar x = x `elem` (" \r\n\t" :: String)

  trimFront []                     = []
  trimFront (l:ls)
    | T.all commentChar l = ls
    | otherwise           = T.dropWhile commentChar l : ls

  dropPrefix []        = []
  dropPrefix [t]       = [T.dropWhile commentChar t]
  dropPrefix ts@(l:ls) =
    case T.uncons l of
      Just (c,_) | prefixDroppable c &&
                   all (commonPrefix c) ls -> dropPrefix (map (T.drop 1) ts)
      _                                    -> ts

    where
    commonPrefix c t =
      case T.uncons t of
        Just (c',_) -> c == c'
        Nothing     -> whitespaceChar c -- end-of-line matches any whitespace


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
                        }

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
                               }
           }

mkInterfaceConstraint ::
  Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint mbDoc ty =
  do ps <- mkProp ty
     pure [DInterfaceConstraint (thing <$> 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 = 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 = mkTopMods
                  . mkModule Located { srcRange = emptyRange
                                     , thing    = mkModName [T.pack "Main"]
                                     }

-- | 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
         }

mkModuleInstance ::
  Located ModName ->
  Located (ImpName PName) ->
  ModuleInstanceArgs PName ->
  Module PName
mkModuleInstance m f as =
  Module { mName    = m
         , mDef     = FunctorInstance f as emptyModuleInstance
         , mInScope = mempty
         }


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 (head ls))
            ["Invalid record field.  Perhaps you meant to update a record?"]

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 rng = loc { from = to (srcRange (head ls)) }
           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  = fromP { col = col fromP + T.length as + 1 } ->
          -- 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) ->
  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]) ->
  ParseM (Located (ImportG (ImpName PName)))

mkImport loc impName optInst mbAs mbImportSpec optImportWhere =
  do i <- getInst
     let end = fromMaybe (srcRange impName)
             $ msum [ srcRange <$> optImportWhere
                    , srcRange <$> mbImportSpec
                    , srcRange <$> mbAs
                    ]

     pure Located { srcRange = rComb loc end
                  , thing    = Import
                                 { iModule    = thing impName
                                 , iAs        = thing <$> mbAs
                                 , iSpec      = thing <$> mbImportSpec
                                 , iInst      = i
                                 }
                  }
  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 :: Module PName -> ParseM [Module PName]
mkTopMods = desugarMod

mkTopSig :: Located ModName -> Signature PName -> [Module PName]
mkTopSig nm sig =
  [ Module { mName    = nm
           , mDef     = InterfaceModule sig
           , mInScope = mempty
           }
  ]


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

data AnonThing = AnonArg | AnonIfaceMod

instance MkAnon ModName where
  mkAnon what   = case what of
                    AnonArg      -> modNameArg
                    AnonIfaceMod -> modNameIfaceMod
  toImpName     = ImpTop

instance MkAnon PName where
  mkAnon what   = mkUnqual
                . case what of
                    AnonArg      -> identAnonArg
                    AnonIfaceMod -> identAnonIfaceMod
                . getIdent
  toImpName     = ImpNested


desugarMod :: MkAnon name => ModuleG name PName -> ParseM [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 (thing (mName mo))
             nm     = Located { srcRange = srcRange (mName mo), thing = i }
             as'    = DefaultInstArg (ModuleArg . toImpName <$> nm)
         pure [ Module
                  { mName = nm, mDef  = NormalModule lds', mInScope = mempty }
              , mo { mDef = FunctorInstance f as' mempty }
              ]

    NormalModule ds ->
      do (newMs, newDs) <- desugarTopDs (mName mo) ds
         pure (newMs ++ [ mo { mDef = NormalModule newDs } ])

    _ -> 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
                             }
                     ]
                  , [ 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 _ <- 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 ms <- desugarMod mo
               cont [ DModule tl { tlValue = NestedModule m } | m <- ms ] sig

          _ -> cont [d] sig

desugarInstImport ::
  Located (ImportG (ImpName PName)) {- ^ The import -} ->
  ModuleInstanceArgs PName          {- ^ The insantiation -} ->
  ParseM [TopDecl PName]
desugarInstImport i inst =
  do ms <- desugarMod
           Module { mName    = i { thing = iname }
                  , mDef     = FunctorInstance
                                 (iModule <$> i) inst emptyModuleInstance
                  , mInScope = mempty
                  }
     pure (DImport (newImp <$> i) : map modTop ms)

  where
  imp = thing i
  iname = mkUnqual
        $ mkIdent
        $ "import of " <> nm <> " at " <> Text.pack (show (pp (srcRange i)))
    where
    nm = case iModule imp of
           ImpTop f    -> modNameToText f
           ImpNested n -> "submodule " <> Text.pack (show (pp n))

  newImp d = d { iModule = ImpNested iname
               , iInst   = Nothing
               }

  modTop m = DModule TopLevel
                       { tlExport = Private
                       , tlDoc    = Nothing
                       , tlValue  = NestedModule m
                       }