module Agda.Compiler.MAlonzo.Pragmas where

import Control.Monad
import Data.Maybe
import Data.Char
import qualified Data.List as List
import qualified Data.Map as Map
import Text.ParserCombinators.ReadP

import Agda.Syntax.Position
import Agda.Syntax.Abstract.Name
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Primitive

import Agda.Utils.Pretty hiding (char)
import Agda.Utils.String ( ltrim )
import Agda.Utils.Three

import Agda.Compiler.Common
import Agda.Compiler.MAlonzo.Misc

import Agda.Utils.Impossible

type HaskellCode = String
type HaskellType = String

-- | GHC backend translation pragmas.
data HaskellPragma
  = HsDefn Range HaskellCode
      --  ^ @COMPILE GHC x = <code>@
  | HsType Range HaskellType
      --  ^ @COMPILE GHC X = type <type>@
  | HsData Range HaskellType [HaskellCode]
      -- ^ @COMPILE GHC X = data D (c₁ | ... | cₙ)
  | HsExport Range HaskellCode
      -- ^ @COMPILE GHC x as f@
  deriving (Int -> HaskellPragma -> ShowS
[HaskellPragma] -> ShowS
HaskellPragma -> [Char]
(Int -> HaskellPragma -> ShowS)
-> (HaskellPragma -> [Char])
-> ([HaskellPragma] -> ShowS)
-> Show HaskellPragma
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HaskellPragma] -> ShowS
$cshowList :: [HaskellPragma] -> ShowS
show :: HaskellPragma -> [Char]
$cshow :: HaskellPragma -> [Char]
showsPrec :: Int -> HaskellPragma -> ShowS
$cshowsPrec :: Int -> HaskellPragma -> ShowS
Show, HaskellPragma -> HaskellPragma -> Bool
(HaskellPragma -> HaskellPragma -> Bool)
-> (HaskellPragma -> HaskellPragma -> Bool) -> Eq HaskellPragma
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HaskellPragma -> HaskellPragma -> Bool
$c/= :: HaskellPragma -> HaskellPragma -> Bool
== :: HaskellPragma -> HaskellPragma -> Bool
$c== :: HaskellPragma -> HaskellPragma -> Bool
Eq)

instance HasRange HaskellPragma where
  getRange :: HaskellPragma -> Range
getRange (HsDefn   Range
r [Char]
_)   = Range
r
  getRange (HsType   Range
r [Char]
_)   = Range
r
  getRange (HsData   Range
r [Char]
_ [[Char]]
_) = Range
r
  getRange (HsExport Range
r [Char]
_)   = Range
r

instance Pretty HaskellPragma where
  pretty :: HaskellPragma -> Doc
pretty = \case
    HsDefn   Range
_r [Char]
hsCode        -> Doc
equals Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
hsCode
    HsType   Range
_r [Char]
hsType        -> Doc
equals Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
hsType
    HsData   Range
_r [Char]
hsType [[Char]]
hsCons -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
      [ Doc
equals, Doc
"data", [Char] -> Doc
text [Char]
hsType
      , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text ([[Char]] -> [Doc]) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
List.intersperse [Char]
"|" [[Char]]
hsCons
      ]
    HsExport Range
_r [Char]
hsCode        -> Doc
"as" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
hsCode

-- Syntax for Haskell pragmas:
--  HsDefn CODE       "= CODE"
--  HsType TYPE       "= type TYPE"
--  HsData NAME CONS  "= data NAME (CON₁ | .. | CONₙ)"
--  HsExport NAME     "as NAME"
parsePragma :: CompilerPragma -> Either String HaskellPragma
parsePragma :: CompilerPragma -> Either [Char] HaskellPragma
parsePragma (CompilerPragma Range
r [Char]
s) =
  case [ HaskellPragma
p | (HaskellPragma
p, [Char]
"") <- ReadP HaskellPragma -> ReadS HaskellPragma
forall a. ReadP a -> ReadS a
readP_to_S ReadP HaskellPragma
pragmaP [Char]
s ] of
    []  -> [Char] -> Either [Char] HaskellPragma
forall a b. a -> Either a b
Left ([Char] -> Either [Char] HaskellPragma)
-> [Char] -> Either [Char] HaskellPragma
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse GHC pragma '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
    [HaskellPragma
p] -> HaskellPragma -> Either [Char] HaskellPragma
forall a b. b -> Either a b
Right HaskellPragma
p
    [HaskellPragma]
ps  -> [Char] -> Either [Char] HaskellPragma
forall a b. a -> Either a b
Left ([Char] -> Either [Char] HaskellPragma)
-> [Char] -> Either [Char] HaskellPragma
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous parse of pragma '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"':\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines ((HaskellPragma -> [Char]) -> [HaskellPragma] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map HaskellPragma -> [Char]
forall a. Show a => a -> [Char]
show [HaskellPragma]
ps)  -- shouldn't happen
  where
    pragmaP :: ReadP HaskellPragma
    pragmaP :: ReadP HaskellPragma
pragmaP = [ReadP HaskellPragma] -> ReadP HaskellPragma
forall a. [ReadP a] -> ReadP a
choice [ ReadP HaskellPragma
exportP, ReadP HaskellPragma
typeP, ReadP HaskellPragma
dataP, ReadP HaskellPragma
defnP ]

    whitespace :: ReadP [Char]
whitespace = ReadP Char -> ReadP [Char]
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isSpace)

    wordsP :: [[Char]] -> ReadP ()
wordsP []     = () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    wordsP ([Char]
w:[[Char]]
ws) = ReadP ()
skipSpaces ReadP () -> ReadP [Char] -> ReadP [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> ReadP [Char]
string [Char]
w ReadP [Char] -> ReadP () -> ReadP ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [[Char]] -> ReadP ()
wordsP [[Char]]
ws

    barP :: ReadP Char
barP = ReadP ()
skipSpaces ReadP () -> ReadP Char -> ReadP Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReadP Char
char Char
'|'

    -- quite liberal
    isIdent :: Char -> Bool
isIdent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c ([Char]
"_.':[]" :: String)
    isOp :: Char -> Bool
isOp Char
c    = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c ([Char]
"()" :: String)
    hsIdent :: ReadP [Char]
hsIdent = ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst (([Char], [Char]) -> [Char])
-> ReadP ([Char], [Char]) -> ReadP [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP [Char] -> ReadP ([Char], [Char])
forall a. ReadP a -> ReadP ([Char], a)
gather ([ReadP [Char]] -> ReadP [Char]
forall a. [ReadP a] -> ReadP a
choice
                [ [Char] -> ReadP [Char]
string [Char]
"()"
                , ReadP Char -> ReadP [Char]
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isIdent)
                , ReadP Char -> ReadP Char -> ReadP [Char] -> ReadP [Char]
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')') (ReadP Char -> ReadP [Char]
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isOp))
                ])
    hsCode :: ReadP [Char]
hsCode  = ReadP Char -> ReadP [Char]
forall a. ReadP a -> ReadP [a]
many1 ReadP Char
get -- very liberal

    paren :: ReadP a -> ReadP a
paren = ReadP Char -> ReadP Char -> ReadP a -> ReadP a
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (ReadP ()
skipSpaces ReadP () -> ReadP Char -> ReadP Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReadP Char
char Char
'(') (ReadP ()
skipSpaces ReadP () -> ReadP Char -> ReadP Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ReadP Char
char Char
')')

    notTypeOrData :: ReadP ()
notTypeOrData = do
      [Char]
s <- ReadP [Char]
look
      Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReadP ()) -> Bool -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` [Char]
s) [[Char]
"type", [Char]
"data"]

    exportP :: ReadP HaskellPragma
exportP = Range -> [Char] -> HaskellPragma
HsExport Range
r ([Char] -> HaskellPragma)
-> ReadP () -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [[Char]] -> ReadP ()
wordsP [[Char]
"as"]        ReadP ([Char] -> HaskellPragma)
-> ReadP [Char] -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
whitespace ReadP ([Char] -> HaskellPragma)
-> ReadP [Char] -> ReadP HaskellPragma
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP [Char]
hsIdent ReadP HaskellPragma -> ReadP () -> ReadP HaskellPragma
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces
    typeP :: ReadP HaskellPragma
typeP   = Range -> [Char] -> HaskellPragma
HsType   Range
r ([Char] -> HaskellPragma)
-> ReadP () -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [[Char]] -> ReadP ()
wordsP [[Char]
"=", [Char]
"type"] ReadP ([Char] -> HaskellPragma)
-> ReadP [Char] -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
whitespace ReadP ([Char] -> HaskellPragma)
-> ReadP [Char] -> ReadP HaskellPragma
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP [Char]
hsCode
    dataP :: ReadP HaskellPragma
dataP   = Range -> [Char] -> [[Char]] -> HaskellPragma
HsData   Range
r ([Char] -> [[Char]] -> HaskellPragma)
-> ReadP () -> ReadP ([Char] -> [[Char]] -> HaskellPragma)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [[Char]] -> ReadP ()
wordsP [[Char]
"=", [Char]
"data"] ReadP ([Char] -> [[Char]] -> HaskellPragma)
-> ReadP [Char] -> ReadP ([Char] -> [[Char]] -> HaskellPragma)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
whitespace ReadP ([Char] -> [[Char]] -> HaskellPragma)
-> ReadP [Char] -> ReadP ([[Char]] -> HaskellPragma)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP [Char]
hsIdent ReadP ([[Char]] -> HaskellPragma)
-> ReadP [[Char]] -> ReadP HaskellPragma
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                                    ReadP [[Char]] -> ReadP [[Char]]
forall {a}. ReadP a -> ReadP a
paren (ReadP [Char] -> ReadP Char -> ReadP [[Char]]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
sepBy (ReadP ()
skipSpaces ReadP () -> ReadP [Char] -> ReadP [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadP [Char]
hsIdent) ReadP Char
barP) ReadP HaskellPragma -> ReadP () -> ReadP HaskellPragma
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
skipSpaces
    defnP :: ReadP HaskellPragma
defnP   = Range -> [Char] -> HaskellPragma
HsDefn   Range
r ([Char] -> HaskellPragma)
-> ReadP () -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [[Char]] -> ReadP ()
wordsP [[Char]
"="]         ReadP ([Char] -> HaskellPragma)
-> ReadP [Char] -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP [Char]
whitespace ReadP ([Char] -> HaskellPragma)
-> ReadP () -> ReadP ([Char] -> HaskellPragma)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  ReadP ()
notTypeOrData ReadP ([Char] -> HaskellPragma)
-> ReadP [Char] -> ReadP HaskellPragma
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP [Char]
hsCode

parseHaskellPragma :: (MonadTCError m, MonadTrace m) => CompilerPragma -> m HaskellPragma
parseHaskellPragma :: forall (m :: * -> *).
(MonadTCError m, MonadTrace m) =>
CompilerPragma -> m HaskellPragma
parseHaskellPragma CompilerPragma
p = CompilerPragma -> m HaskellPragma -> m HaskellPragma
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange CompilerPragma
p (m HaskellPragma -> m HaskellPragma)
-> m HaskellPragma -> m HaskellPragma
forall a b. (a -> b) -> a -> b
$
  case CompilerPragma -> Either [Char] HaskellPragma
parsePragma CompilerPragma
p of
    Left [Char]
err -> [Char] -> m HaskellPragma
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
[Char] -> m a
genericError [Char]
err
    Right HaskellPragma
p  -> HaskellPragma -> m HaskellPragma
forall (m :: * -> *) a. Monad m => a -> m a
return HaskellPragma
p

getHaskellPragma :: QName -> TCM (Maybe HaskellPragma)
getHaskellPragma :: QName -> TCM (Maybe HaskellPragma)
getHaskellPragma QName
q = do
  Maybe HaskellPragma
pragma <- (CompilerPragma -> TCMT IO HaskellPragma)
-> Maybe CompilerPragma -> TCM (Maybe HaskellPragma)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CompilerPragma -> TCMT IO HaskellPragma
forall (m :: * -> *).
(MonadTCError m, MonadTrace m) =>
CompilerPragma -> m HaskellPragma
parseHaskellPragma (Maybe CompilerPragma -> TCM (Maybe HaskellPragma))
-> TCMT IO (Maybe CompilerPragma) -> TCM (Maybe HaskellPragma)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> QName -> TCMT IO (Maybe CompilerPragma)
getUniqueCompilerPragma [Char]
ghcBackendName QName
q
  Definition
def <- QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
q
  Maybe HaskellPragma
-> TCM (Maybe HaskellPragma) -> TCM (Maybe HaskellPragma)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Maybe HaskellPragma
pragma (TCM (Maybe HaskellPragma) -> TCM (Maybe HaskellPragma))
-> TCM (Maybe HaskellPragma) -> TCM (Maybe HaskellPragma)
forall a b. (a -> b) -> a -> b
$ Maybe HaskellPragma
pragma Maybe HaskellPragma -> TCMT IO () -> TCM (Maybe HaskellPragma)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Definition -> Maybe HaskellPragma -> TCMT IO ()
forall (m :: * -> *).
(HasBuiltins m, MonadTCError m, MonadReduce m) =>
Definition -> Maybe HaskellPragma -> m ()
sanityCheckPragma Definition
def Maybe HaskellPragma
pragma

sanityCheckPragma :: (HasBuiltins m, MonadTCError m, MonadReduce m) => Definition -> Maybe HaskellPragma -> m ()
sanityCheckPragma :: forall (m :: * -> *).
(HasBuiltins m, MonadTCError m, MonadReduce m) =>
Definition -> Maybe HaskellPragma -> m ()
sanityCheckPragma Definition
_ Maybe HaskellPragma
Nothing = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sanityCheckPragma Definition
def (Just HsDefn{}) =
  case Definition -> Defn
theDef Definition
def of
    Axiom{}        -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Function{}     -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    AbstractDefn{} -> m ()
forall a. HasCallStack => a
__IMPOSSIBLE__
    Datatype{}     -> [Char] -> m ()
forall {m :: * -> *} {a}.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
[Char] -> m a
recOrDataErr [Char]
"data"
    Record{}       -> [Char] -> m ()
forall {m :: * -> *} {a}.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
[Char] -> m a
recOrDataErr [Char]
"record"
    Defn
_              -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m ()) -> TypeError -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError [Char]
"Haskell definitions can only be given for postulates and functions."
    where
      recOrDataErr :: [Char] -> m a
recOrDataErr [Char]
which =
        TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError (Doc -> TypeError) -> Doc -> TypeError
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"Bad COMPILE GHC pragma for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
which [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" type. Use"
              , Doc
"{-# COMPILE GHC <Name> = data <HsData> (<HsCon1> | .. | <HsConN>) #-}" ]
sanityCheckPragma Definition
def (Just HsData{}) =
  case Definition -> Defn
theDef Definition
def of
    Datatype{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Record{}   -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Defn
_          -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m ()) -> TypeError -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError [Char]
"Haskell data types can only be given for data or record types."
sanityCheckPragma Definition
def (Just HsType{}) =
  case Definition -> Defn
theDef Definition
def of
    Axiom{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Datatype{} -> do
      -- We use HsType pragmas for Nat, Int and Bool
      Maybe QName
nat  <- [Char] -> m (Maybe QName)
forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
[Char] -> m (Maybe QName)
getBuiltinName [Char]
builtinNat
      Maybe QName
int  <- [Char] -> m (Maybe QName)
forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
[Char] -> m (Maybe QName)
getBuiltinName [Char]
builtinInteger
      Maybe QName
bool <- [Char] -> m (Maybe QName)
forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
[Char] -> m (Maybe QName)
getBuiltinName [Char]
builtinBool
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QName -> Maybe QName
forall a. a -> Maybe a
Just (Definition -> QName
defName Definition
def) Maybe QName -> [Maybe QName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe QName
nat, Maybe QName
int, Maybe QName
bool]) m ()
forall {a}. m a
err
    Defn
_ -> m ()
forall {a}. m a
err
  where
    err :: m a
err = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError [Char]
"Haskell types can only be given for postulates."
sanityCheckPragma Definition
def (Just HsExport{}) =
  case Definition -> Defn
theDef Definition
def of
    Function{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Defn
_ -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m ()) -> TypeError -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError [Char]
"Only functions can be exported to Haskell using {-# COMPILE GHC <Name> as <HsName> #-}"



-- TODO: cache this to avoid parsing the pragma for every constructor
--       occurrence!
getHaskellConstructor :: QName -> HsCompileM (Maybe HaskellCode)
getHaskellConstructor :: QName -> HsCompileM (Maybe [Char])
getHaskellConstructor QName
c = do
  QName
c    <- QName
-> ReaderT GHCModuleEnv (StateT HsCompileState (TCMT IO)) QName
forall (m :: * -> *). HasConstInfo m => QName -> m QName
canonicalName QName
c
  Defn
cDef <- Definition -> Defn
theDef (Definition -> Defn)
-> ReaderT
     GHCModuleEnv (StateT HsCompileState (TCMT IO)) Definition
-> ReaderT GHCModuleEnv (StateT HsCompileState (TCMT IO)) Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName
-> ReaderT
     GHCModuleEnv (StateT HsCompileState (TCMT IO)) Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
c
  GHCEnv
env  <- ReaderT GHCModuleEnv (StateT HsCompileState (TCMT IO)) GHCEnv
forall (m :: * -> *). ReadGHCModuleEnv m => m GHCEnv
askGHCEnv
  let is :: QName -> (GHCEnv -> Maybe QName) -> Bool
is QName
c GHCEnv -> Maybe QName
p = QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== GHCEnv -> Maybe QName
p GHCEnv
env
  case Defn
cDef of
    Defn
_ | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvTrue    -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"True"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvFalse   -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"False"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvNil     -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"[]"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvCons    -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"(:)"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvNothing -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Nothing"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvJust    -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Just"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvSharp   -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"MAlonzo.RTE.Sharp"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvIZero   -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"False"
      | QName
c QName -> (GHCEnv -> Maybe QName) -> Bool
`is` GHCEnv -> Maybe QName
ghcEnvIOne    -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"True"
    Constructor{conData :: Defn -> QName
conData = QName
d} -> do
      Maybe HaskellPragma
mp <- TCM (Maybe HaskellPragma)
-> ReaderT
     GHCModuleEnv
     (StateT HsCompileState (TCMT IO))
     (Maybe HaskellPragma)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Maybe HaskellPragma)
 -> ReaderT
      GHCModuleEnv
      (StateT HsCompileState (TCMT IO))
      (Maybe HaskellPragma))
-> TCM (Maybe HaskellPragma)
-> ReaderT
     GHCModuleEnv
     (StateT HsCompileState (TCMT IO))
     (Maybe HaskellPragma)
forall a b. (a -> b) -> a -> b
$ QName -> TCM (Maybe HaskellPragma)
getHaskellPragma QName
d
      case Maybe HaskellPragma
mp of
        Just (HsData Range
_ [Char]
_ [[Char]]
hsCons) -> do
          [QName]
cons <- Defn -> [QName]
defConstructors (Defn -> [QName]) -> (Definition -> Defn) -> Definition -> [QName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef (Definition -> [QName])
-> ReaderT
     GHCModuleEnv (StateT HsCompileState (TCMT IO)) Definition
-> ReaderT GHCModuleEnv (StateT HsCompileState (TCMT IO)) [QName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName
-> ReaderT
     GHCModuleEnv (StateT HsCompileState (TCMT IO)) Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
          Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> HsCompileM (Maybe [Char]))
-> Maybe [Char] -> HsCompileM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ QName -> [(QName, [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
c ([(QName, [Char])] -> Maybe [Char])
-> [(QName, [Char])] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [QName] -> [[Char]] -> [(QName, [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [QName]
cons [[Char]]
hsCons
        Maybe HaskellPragma
_ -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
    Defn
_ -> Maybe [Char] -> HsCompileM (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing

-- | Get content of @FOREIGN GHC@ pragmas, sorted by 'KindOfForeignCode':
--   file header pragmas, import statements, rest.
foreignHaskell :: Interface -> ([String], [String], [String])
foreignHaskell :: Interface -> ([[Char]], [[Char]], [[Char]])
foreignHaskell = ([Char] -> KindOfForeignCode)
-> [[Char]] -> ([[Char]], [[Char]], [[Char]])
forall a. (a -> KindOfForeignCode) -> [a] -> ([a], [a], [a])
partitionByKindOfForeignCode [Char] -> KindOfForeignCode
classifyForeign
    ([[Char]] -> ([[Char]], [[Char]], [[Char]]))
-> (Interface -> [[Char]])
-> Interface
-> ([[Char]], [[Char]], [[Char]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ForeignCode -> [Char]) -> [ForeignCode] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ForeignCode -> [Char]
getCode ([ForeignCode] -> [[Char]])
-> (Interface -> [ForeignCode]) -> Interface -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ForeignCode] -> Maybe [ForeignCode] -> [ForeignCode]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [ForeignCode] -> [ForeignCode])
-> (Interface -> Maybe [ForeignCode]) -> Interface -> [ForeignCode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Map [Char] [ForeignCode] -> Maybe [ForeignCode]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
ghcBackendName (Map [Char] [ForeignCode] -> Maybe [ForeignCode])
-> (Interface -> Map [Char] [ForeignCode])
-> Interface
-> Maybe [ForeignCode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Map [Char] [ForeignCode]
iForeignCode
  where getCode :: ForeignCode -> [Char]
getCode (ForeignCode Range
_ [Char]
code) = [Char]
code

-- | Classify @FOREIGN@ Haskell code.
data KindOfForeignCode
  = ForeignFileHeaderPragma
      -- ^ A pragma that must appear before the module header.
  | ForeignImport
      -- ^ An import statement.  Must appear right after the module header.
  | ForeignOther
      -- ^ The rest.  To appear after the import statements.

-- | Classify a @FOREIGN GHC@ declaration.
classifyForeign :: String -> KindOfForeignCode
classifyForeign :: [Char] -> KindOfForeignCode
classifyForeign [Char]
s0 = case ShowS
ltrim [Char]
s0 of
  [Char]
s | [Char]
"import " [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` [Char]
s -> KindOfForeignCode
ForeignImport
  [Char]
s | [Char]
"{-#" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` [Char]
s -> [Char] -> KindOfForeignCode
classifyPragma ([Char] -> KindOfForeignCode) -> [Char] -> KindOfForeignCode
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
3 [Char]
s
  [Char]
_ -> KindOfForeignCode
ForeignOther

-- | Classify a Haskell pragma into whether it is a file header pragma or not.
classifyPragma :: String -> KindOfForeignCode
classifyPragma :: [Char] -> KindOfForeignCode
classifyPragma [Char]
s0 = case ShowS
ltrim [Char]
s0 of
  [Char]
s | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` [Char]
s) [[Char]]
fileHeaderPragmas -> KindOfForeignCode
ForeignFileHeaderPragma
  [Char]
_ -> KindOfForeignCode
ForeignOther
  where
  fileHeaderPragmas :: [[Char]]
fileHeaderPragmas =
    [ [Char]
"LANGUAGE"
    , [Char]
"OPTIONS_GHC"
    , [Char]
"INCLUDE"
    ]

-- | Partition a list by 'KindOfForeignCode' attribute.
partitionByKindOfForeignCode :: (a -> KindOfForeignCode) -> [a] -> ([a], [a], [a])
partitionByKindOfForeignCode :: forall a. (a -> KindOfForeignCode) -> [a] -> ([a], [a], [a])
partitionByKindOfForeignCode a -> KindOfForeignCode
f = (a -> Three) -> [a] -> ([a], [a], [a])
forall a. (a -> Three) -> [a] -> ([a], [a], [a])
partition3 ((a -> Three) -> [a] -> ([a], [a], [a]))
-> (a -> Three) -> [a] -> ([a], [a], [a])
forall a b. (a -> b) -> a -> b
$ KindOfForeignCode -> Three
toThree (KindOfForeignCode -> Three)
-> (a -> KindOfForeignCode) -> a -> Three
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> KindOfForeignCode
f
  where
  toThree :: KindOfForeignCode -> Three
toThree = \case
    KindOfForeignCode
ForeignFileHeaderPragma -> Three
One
    KindOfForeignCode
ForeignImport           -> Three
Two
    KindOfForeignCode
ForeignOther            -> Three
Three