module Language.ATS.Generate
( exec
, generateATS
) where
import Cases (snakify)
import Control.Lens (over, _head)
import Data.Char (toUpper)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Language.ATS as ATS
import Language.Haskell.Exts.Parser
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 -> String
qnameToString (QNamed _ _ s) = convertConventions s
qnameToString _ = undefined
toStringATS' :: QName a -> ATS.Type
toStringATS' (QNamed _ _ "Int") = ATS.Int
toStringATS' (QNamed _ _ "Float") = ATS.Float
toStringATS' (QNamed _ _ "Integer") = Named (Unqualified "Intinf")
toStringATS' (QNamed _ _ "String") = Named (Unqualified "Strptr1")
toStringATS' (QNamed _ _ "Bool") = ATS.Bool
toStringATS' (QNamed _ _ "Word") = Named (Unqualified "uint")
toStringATS' (QNamed _ _ "Double") = ATS.Double
toStringATS' _ = undefined
typeToType :: HS.Type a -> ATS.Type
typeToType (TyCon _ qn) = toStringATS' qn
typeToType (TyVar _ n) = Named $ Unqualified (toStringATS n)
typeToType (TyApp _ (TyCon _ qn) t'@TyCon{}) = Dependent (Unqualified $ qnameToString qn) [typeToType t']
typeToType (TyApp _ t@TyApp{} t'@TyCon{}) = over typeCallArgs (typeToType t':) $ typeToType t
typeToType (TyParen _ t) = typeToType t
typeToType (TyBang _ _ _ t) = typeToType t
typeToType (TyList _ t) = Dependent (Unqualified "List_vt") [typeToType t]
typeToType _ = undefined
fieldDeclToType :: FieldDecl a -> (String, ATS.Type)
fieldDeclToType (FieldDecl _ [n] t) = (toStringATS n, typeToType t)
fieldDeclToType _ = undefined
conDeclToType :: ConDecl a -> (String, Maybe ATS.Type)
conDeclToType (ConDecl _ n []) = (toStringATS n, Nothing)
conDeclToType (ConDecl _ n [t]) = (toStringATS n, Just $ typeToType t)
conDeclToType (RecDecl _ n fs) = (toStringATS n, Just $ AnonymousRecord undefined (fieldDeclToType <$> reverse fs))
conDeclToType _ = undefined
toStringATS :: HS.Name a -> String
toStringATS (Ident _ s) = s
toStringATS _ = undefined
tyvarToArg :: TyVarBind a -> Arg
tyvarToArg (UnkindedVar _ n) = Arg (Both (toStringATS n) (Vt0p Plus))
tyvarToArg _ = undefined
asATSName :: DeclHead a -> (String, [Arg])
asATSName (DHead _ n) = (convertConventions $ toStringATS n, [])
asATSName (DHParen _ d) = (fst $ asATSName d, [])
asATSName (DHApp _ d tb) = (fst $ asATSName d, tyvarToArg tb : snd (asATSName d))
asATSName _ = undefined
qualConDeclToType :: QualConDecl a -> ATS.Type
qualConDeclToType (EmptyQualCon _ cd) = fromJust $ snd $ conDeclToType cd
qualConDeclToType _ = undefined
qualConDeclToLeaf :: QualConDecl a -> Leaf
qualConDeclToLeaf (EmptyQualCon _ cd) = Leaf [] (over _head toUpper $ convertConventions $ fst $ conDeclToType cd) [] (snd $ conDeclToType cd)
qualConDeclToLeaf _ = undefined
asATSType :: Decl a -> Declaration
asATSType (DataDecl _ NewType{} _ dh [qcd] _) = ViewTypeDef undefined (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToType qcd)
asATSType (DataDecl _ DataType{} _ dh [qcd] _) = ViewTypeDef undefined (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToType qcd)
asATSType (DataDecl _ DataType{} _ dh qcds _) = SumViewType (fst $ asATSName dh) (snd $ asATSName dh) (qualConDeclToLeaf <$> reverse qcds)
asATSType _ = undefined
isDataDecl :: Decl a -> Bool
isDataDecl DataDecl{} = True
isDataDecl _ = False
filterModule :: Module a -> [Decl a]
filterModule (Module _ _ _ _ ds) = filter isDataDecl ds
filterModule _ = []
modulePrint :: Module a -> String
modulePrint = printATS . ATS . reverse . fmap asATSType . filterModule
generateATS :: String -> String
generateATS hsSrc = modulePrint $ case parseModule hsSrc of
ParseOk x -> x
ParseFailed loc msg -> error (show loc ++ "\n" ++ msg)
withFile :: FilePath -> FilePath -> IO ()
withFile p p' = do
contents <- readFile p
writeFile p' (generateATS contents)
exec :: IO ()
exec = do
x <- getRecord "Generate ATS types for Haskell source code" :: IO Program
withFile (unHelpful . src $ x) (unHelpful . target $ x)