module Language.ATS.Generate
( exec
, generateATS
, genATSTypes
, ErrM
) where
import Cases (snakify)
import Control.Arrow
import Control.Lens (over, _head)
import Data.Char (toUpper)
import Data.Either (lefts, rights)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Language.ATS as ATS
import Language.ATS.Generate.Error
import Language.Haskell.Exts
import Language.Haskell.Exts.Syntax as HS
import Options.Generic
data Program = Program { src :: FilePath <?> "Haskell source file"
, target :: FilePath <?> "ATS target"
} deriving (Generic, ParseRecord)
convertConventions :: String -> String
convertConventions = T.unpack . snakify . T.pack
pattern QNamed :: l -> l -> String -> QName l
pattern QNamed x y s = UnQual x (Ident y s)
pattern EmptyQualCon :: l -> ConDecl l -> QualConDecl l
pattern EmptyQualCon x cd = QualConDecl x Nothing Nothing cd
qnameToString :: QName a -> ErrM String
qnameToString (QNamed _ _ s) = Right $ convertConventions s
qnameToString _ = unsupported "qnameToString"
toStringATS' :: QName a -> ErrM ATS.Type
toStringATS' (QNamed _ _ "Int") = Right ATS.Int
toStringATS' (QNamed _ _ "Float") = Right ATS.Float
toStringATS' (QNamed _ _ "Integer") = Right $ Named (Unqualified "Intinf")
toStringATS' (QNamed _ _ "String") = Right $ Named (Unqualified "Strptr1")
toStringATS' (QNamed _ _ "Bool") = Right ATS.Bool
toStringATS' (QNamed _ _ "Word") = Right $ Named (Unqualified "uint")
toStringATS' (QNamed _ _ "Double") = Right ATS.Double
toStringATS' _ = unsupported "toStringATS'"
typeToType :: HS.Type a -> ErrM ATS.Type
typeToType (TyCon _ qn) = toStringATS' qn
typeToType (TyVar _ n) = Right $ Named $ Unqualified (toStringATS n)
typeToType (TyApp _ (TyCon _ qn) t'@TyCon{}) = Dependent <$> (Unqualified <$> qnameToString qn) <*> (pure <$> typeToType t')
typeToType (TyApp _ t@TyApp{} t'@TyCon{}) = over typeCallArgs <$> fmap (:) (typeToType t') <*> typeToType t
typeToType (TyParen _ t) = typeToType t
typeToType (TyBang _ _ _ t) = typeToType t
typeToType (TyList _ t) = Dependent (Unqualified "List_vt") <$> (pure <$> typeToType t)
typeToType _ = Left $ Unsupported "typeToType"
fieldDeclToType :: FieldDecl a -> ErrM (String, ATS.Type)
fieldDeclToType (FieldDecl _ [n] t) = (,) (toStringATS n) <$> typeToType t
fieldDeclToType _ = Left $ Unsupported "fieldDeclToType"
conDeclToType :: ConDecl a -> ErrM (String, Maybe ATS.Type)
conDeclToType (ConDecl _ n []) = Right (toStringATS n, Nothing)
conDeclToType (ConDecl _ n [t]) = (,) (toStringATS n) . Just <$> typeToType t
conDeclToType (RecDecl _ n fs) = (,) (toStringATS n) . Just . AnonymousRecord undefined <$> mapM fieldDeclToType (reverse fs)
conDeclToType _ = unsupported "conDeclToType"
toStringATS :: HS.Name a -> String
toStringATS (Ident _ s) = s
toStringATS _ = undefined
tyvarToArg :: Bool -> TyVarBind a -> ErrM Arg
tyvarToArg False (UnkindedVar _ n) = Right $ Arg (Both (toStringATS n) (Vt0p None))
tyvarToArg True (UnkindedVar _ n) = Right $ Arg (Both (toStringATS n) (Vt0p Plus))
tyvarToArg _ _ = unsupported "tyvarToArg"
consM :: (Monad m) => m a -> m [a] -> m [a]
consM x xs = (:) <$> x <*> xs
asATSName :: DeclHead a -> ErrM (String, [Arg])
asATSName (DHead _ n) = Right (convertConventions $ toStringATS n, [])
asATSName (DHParen _ d) = (,) . fst <$> asATSName d <*> pure []
asATSName (DHApp _ d tb) = (,) . fst <$> asATSName d <*> consM (tyvarToArg False tb) (snd <$> asATSName d)
asATSName _ = unsupported "asATSName"
qualConDeclToType :: QualConDecl a -> ErrM ATS.Type
qualConDeclToType (EmptyQualCon _ cd) = fromJust . snd <$> conDeclToType cd
qualConDeclToType _ = unsupported "qualConDeclToType"
qualConDeclToLeaf :: QualConDecl a -> ErrM Leaf
qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] <$> (over _head toUpper . convertConventions . fst <$> conDeclToType cd) <*> pure [] <*> (snd <$> conDeclToType cd)
qualConDeclToLeaf _ = unsupported "qualConDeclToLeaf"
addNils :: [Arg] -> [Arg]
addNils [] = [NoArgs]
addNils x = x
asATSType :: Decl a -> ErrM Declaration
asATSType (TypeDecl _ dh t) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> typeToType t
asATSType (DataDecl _ NewType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> qualConDeclToType qcd
asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> qualConDeclToType qcd
asATSType (DataDecl _ DataType{} _ dh qcds _) = SumViewType <$> (fst <$> asATSName dh) <*> (addNils . snd <$> asATSName dh) <*> mapM qualConDeclToLeaf (reverse qcds)
asATSType _ = unsupported "asATSType"
isDataDecl :: Decl a -> Bool
isDataDecl TypeDecl{} = True
isDataDecl DataDecl{} = True
isDataDecl _ = False
filterModule :: Module a -> [Decl a]
filterModule (Module _ _ _ _ ds) = filter isDataDecl ds
filterModule _ = []
modulePrint :: Module a -> (String, [GenerateError])
modulePrint = g . fmap asATSType . filterModule
where g = (printATS . ATS . reverse . rights) &&& lefts
extends :: ParseMode
extends = defaultParseMode
{ extensions = [EnableExtension StandaloneDeriving] }
generateATS :: String -> ErrM (String, [GenerateError])
generateATS hsSrc = modulePrint <$> case parseModuleWithMode extends hsSrc of
ParseOk x -> Right x
ParseFailed loc' msg -> syntaxError loc' msg
genATSTypes :: FilePath -> FilePath -> IO ()
genATSTypes p p' = do
contents <- readFile p
let warnDo (x, es) = mapM_ displayErr es >> writeFile p' x
either displayErr warnDo (generateATS contents)
exec :: IO ()
exec = do
x <- getRecord "Generate ATS types for Haskell source code" :: IO Program
genATSTypes (unHelpful . src $ x) (unHelpful . target $ x)