module Processing where

import Data.Either (rights)
import Data.List (partition)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Language.TL.AST
import qualified Language.TL.AST as A
import Language.TL.Comment
import Language.TL.Types
import qualified Language.TL.Types as T
import Text.Megaparsec

getComment :: Comment -> Text
getComment :: Comment -> Text
getComment (LineComment t :: Text
t) = Text
t
getComment (BlockComment t :: Text
t) = Text
t

type CombD = ([[Attr]], Combinator)

parseComments :: [Comment] -> [[Attr]]
parseComments :: [Comment] -> [[Attr]]
parseComments = [Either (ParseErrorBundle Text Void) [Attr]] -> [[Attr]]
forall a b. [Either a b] -> [b]
rights ([Either (ParseErrorBundle Text Void) [Attr]] -> [[Attr]])
-> ([Comment] -> [Either (ParseErrorBundle Text Void) [Attr]])
-> [Comment]
-> [[Attr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comment -> Either (ParseErrorBundle Text Void) [Attr])
-> [Comment] -> [Either (ParseErrorBundle Text Void) [Attr]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Parsec Void Text [Attr]
-> String -> Text -> Either (ParseErrorBundle Text Void) [Attr]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec Void Text [Attr]
attrs "" (Text -> Either (ParseErrorBundle Text Void) [Attr])
-> (Comment -> Text)
-> Comment
-> Either (ParseErrorBundle Text Void) [Attr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> Text
getComment)

hasClassAttr :: [Attr] -> Bool
hasClassAttr :: [Attr] -> Bool
hasClassAttr = (Attr -> Bool) -> [Attr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(t :: Text
t, _) -> Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "class")

classDesc :: [[Attr]] -> Maybe Text
classDesc :: [[Attr]] -> Maybe Text
classDesc l :: [[Attr]]
l =
  let (t :: [[Attr]]
t, _) = ([Attr] -> Bool) -> [[Attr]] -> ([[Attr]], [[Attr]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition [Attr] -> Bool
hasClassAttr [[Attr]]
l
      l' :: [Attr]
l' = if [[Attr]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Attr]]
t then [] else [[Attr]] -> [Attr]
forall a. [a] -> a
head [[Attr]]
t
      desc :: Maybe Text
desc = Text -> [Attr] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "description" [Attr]
l'
   in Maybe Text
desc

constructDoc :: [[Attr]] -> Doc
constructDoc :: [[Attr]] -> Doc
constructDoc = [Attr] -> Doc
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Attr] -> Doc) -> ([[Attr]] -> [Attr]) -> [[Attr]] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Attr]] -> [Attr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

tyConName :: Type -> Text
tyConName :: Type -> Text
tyConName (A.Type t :: Text
t) = Text
t
tyConName (A.TypeApp (A.Type t :: Text
t) _) = Text
t
tyConName _ = String -> Text
forall a. HasCallStack => String -> a
error "not a type constructor"

combType :: Combinator -> Text
combType :: Combinator -> Text
combType = Type -> Text
tyConName (Type -> Text) -> (Combinator -> Type) -> Combinator -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Combinator -> Type
A.resType

splitDecls :: [CombD] -> ([CombD], [CombD])
splitDecls :: [CombD] -> ([CombD], [CombD])
splitDecls decls :: [CombD]
decls =
  let (_, c :: Combinator
c) = [CombD] -> CombD
forall a. [a] -> a
head [CombD]
decls
      tyIdent :: Text
tyIdent = Combinator -> Text
combType Combinator
c
   in (CombD -> Bool) -> [CombD] -> ([CombD], [CombD])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\(_, c' :: Combinator
c') -> Combinator -> Text
combType Combinator
c' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
tyIdent) [CombD]
decls

formADT :: [CombD] -> ADT
formADT :: [CombD] -> ADT
formADT decls :: [CombD]
decls =
  let (l :: [[Attr]]
l, c :: Combinator
c) = [CombD] -> CombD
forall a. [a] -> a
head [CombD]
decls
      ann :: Maybe Text
ann = [[Attr]] -> Maybe Text
classDesc [[Attr]]
l
      name :: Text
name = Combinator -> Text
combType Combinator
c
      constructors :: [Combinator]
constructors = (CombD -> Combinator) -> [CombD] -> [Combinator]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CombD -> Combinator
forall a b. (a, b) -> b
snd [CombD]
decls
   in $WADT :: Text -> Maybe Text -> [Combinator] -> ADT
ADT {..}

oneADT :: [CombD] -> (ADT, [CombD])
oneADT :: [CombD] -> (ADT, [CombD])
oneADT decls :: [CombD]
decls =
  let (h :: [CombD]
h, rest :: [CombD]
rest) = [CombD] -> ([CombD], [CombD])
splitDecls [CombD]
decls
   in ([CombD] -> ADT
formADT [CombD]
h, [CombD]
rest)

filterAnnDecl :: [AnnDecl] -> [CombD]
filterAnnDecl :: [AnnDecl] -> [CombD]
filterAnnDecl [] = []
filterAnnDecl (AnnDecl cmt :: [Comment]
cmt (T.Combinator c :: CombinatorDecl
c) : xs :: [AnnDecl]
xs) =
  let l :: [[Attr]]
l = [Comment] -> [[Attr]]
parseComments [Comment]
cmt
   in ([[Attr]]
l, Doc -> CombinatorDecl -> Combinator
combConv ([[Attr]] -> Doc
constructDoc [[Attr]]
l) CombinatorDecl
c) CombD -> [CombD] -> [CombD]
forall a. a -> [a] -> [a]
: [AnnDecl] -> [CombD]
filterAnnDecl [AnnDecl]
xs
filterAnnDecl (_ : xs :: [AnnDecl]
xs) = [AnnDecl] -> [CombD]
filterAnnDecl [AnnDecl]
xs

declBlockToADT :: [CombD] -> [ADT]
declBlockToADT :: [CombD] -> [ADT]
declBlockToADT [] = []
declBlockToADT decls :: [CombD]
decls =
  let (h :: ADT
h, rest :: [CombD]
rest) = [CombD] -> (ADT, [CombD])
oneADT [CombD]
decls
   in ADT
h ADT -> [ADT] -> [ADT]
forall a. a -> [a] -> [a]
: [CombD] -> [ADT]
declBlockToADT [CombD]
rest

declBlockToFun :: [CombD] -> [Function]
declBlockToFun :: [CombD] -> [Function]
declBlockToFun = (CombD -> Function) -> [CombD] -> [Function]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(_, c :: Combinator
c) -> Combinator -> Function
Function Combinator
c)

convProgram :: Program -> ([ADT], [Function])
convProgram :: Program -> ([ADT], [Function])
convProgram prog :: Program
prog =
  (DeclBlock -> ([ADT], [Function]) -> ([ADT], [Function]))
-> ([ADT], [Function]) -> Program -> ([ADT], [Function])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    ( \blk :: DeclBlock
blk (c :: [ADT]
c, f :: [Function]
f) -> case DeclBlock
blk of
        FunDeclBlk decls :: [AnnDecl]
decls -> ([ADT]
c, ([CombD] -> [Function]
declBlockToFun ([CombD] -> [Function]) -> [CombD] -> [Function]
forall a b. (a -> b) -> a -> b
$ [AnnDecl] -> [CombD]
filterAnnDecl [AnnDecl]
decls) [Function] -> [Function] -> [Function]
forall a. Semigroup a => a -> a -> a
<> [Function]
f)
        TypeDeclBlk decls :: [AnnDecl]
decls -> (([CombD] -> [ADT]
declBlockToADT ([CombD] -> [ADT]) -> [CombD] -> [ADT]
forall a b. (a -> b) -> a -> b
$ [AnnDecl] -> [CombD]
filterAnnDecl [AnnDecl]
decls) [ADT] -> [ADT] -> [ADT]
forall a. Semigroup a => a -> a -> a
<> [ADT]
c, [Function]
f)
    )
    ([], [])
    Program
prog