{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Generate code using types emitted from XSD.
module Fadno.Xml.Codegen
    (
     -- * Codegen API
     outputTypes,outputType,outputHeader
    -- * Monad
    ,Output
    ,OutputState(..),names
    ,OutputEnv(..),handle
    ,runOut,runOut'
    ) where

import Fadno.Xml.EmitTypes
import Fadno.Xml.ParseXsd
import Control.Lens hiding (Choice,element,elements)
import Control.Monad.State.Strict
import Control.Monad.Reader
import qualified Data.Map.Strict as M
import Data.Char
import System.IO
import Data.List (intercalate)
import Data.Maybe


-- | Codegen state.
data OutputState = OutputState { OutputState -> Map String Name
_names :: M.Map String Name }
$(makeLenses ''OutputState)
-- | Codegen reader environment.
data OutputEnv = OutputEnv { OutputEnv -> Handle
_handle :: Handle }
$(makeLenses ''OutputEnv)

-- | Codegen monad.
type Output a = ReaderT OutputEnv (StateT OutputState IO) a

-- | Enumerate types to avoid in mangling.
defaultNames :: M.Map String Name
defaultNames :: Map String Name
defaultNames = [(String, Name)] -> Map String Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Name)] -> Map String Name)
-> [(String, Name)] -> Map String Name
forall a b. (a -> b) -> a -> b
$ (String -> (String, Name)) -> [String] -> [(String, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
n -> (String
n,Namespace -> QN -> Int -> Name
Name Namespace
NSBuiltIn (String -> Maybe String -> QN
QN String
n Maybe String
forall a. Maybe a
Nothing) Int
0))
               [String
"Eq",String
"Typeable",String
"Generic",String
"Ord",String
"Bounded",
                String
"Enum",String
"Num",String
"Real",String
"Integral",String
"Show",
               String
"String",String
"Double",String
"Float",String
"Boolean",String
"Int"]

-- | Run output monad.
runOut :: OutputEnv -> OutputState -> Output a -> IO (a, OutputState)
runOut :: OutputEnv -> OutputState -> Output a -> IO (a, OutputState)
runOut OutputEnv
e OutputState
s Output a
a = StateT OutputState IO a -> OutputState -> IO (a, OutputState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Output a -> OutputEnv -> StateT OutputState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Output a
a OutputEnv
e) OutputState
s

-- | Convenience runner.
runOut' :: Handle -> Output a -> IO (a, OutputState)
runOut' :: Handle -> Output a -> IO (a, OutputState)
runOut' Handle
h = OutputEnv -> OutputState -> Output a -> IO (a, OutputState)
forall a.
OutputEnv -> OutputState -> Output a -> IO (a, OutputState)
runOut (Handle -> OutputEnv
OutputEnv Handle
h) (Map String Name -> OutputState
OutputState Map String Name
defaultNames)

-- | putStr in codegen.
outStr :: String -> Output ()
outStr :: String -> Output ()
outStr String
s = Getting Handle OutputEnv Handle
-> ReaderT OutputEnv (StateT OutputState IO) Handle
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Handle OutputEnv Handle
Iso' OutputEnv Handle
handle ReaderT OutputEnv (StateT OutputState IO) Handle
-> (Handle -> Output ()) -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> IO () -> Output ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Output ()) -> IO () -> Output ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h String
s

-- | putStrLn in codegen.
outStrLn :: String -> Output ()
outStrLn :: String -> Output ()
outStrLn String
s = Getting Handle OutputEnv Handle
-> ReaderT OutputEnv (StateT OutputState IO) Handle
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Handle OutputEnv Handle
Iso' OutputEnv Handle
handle ReaderT OutputEnv (StateT OutputState IO) Handle
-> (Handle -> Output ()) -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> IO () -> Output ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Output ()) -> IO () -> Output ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
s

-- | indent.
indent :: Int -> Output ()
indent :: Int -> Output ()
indent Int
i = String -> Output ()
outStr (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' '

-- | Output all types.
outputTypes :: EmitState -> Output ()
outputTypes :: EmitState -> Output ()
outputTypes = (Type -> Output ()) -> [Type] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type -> Output ()
outputType ([Type] -> Output ())
-> (EmitState -> [Type]) -> EmitState -> Output ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Type -> [Type]
forall k a. Map k a -> [a]
M.elems (Map Name Type -> [Type])
-> (EmitState -> Map Name Type) -> EmitState -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmitState -> Map Name Type
_types

-- | Comment header.
header :: Name -> Maybe Documentation -> Output ()
header :: Name -> Maybe Documentation -> Output ()
header (Name Namespace
ns QN
n Int
i) Maybe Documentation
doc = do
  String -> Output ()
outStrLn String
""
  String -> Output ()
outStr (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"-- | @" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@"
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
" /(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Namespace -> String
forall a. Show a => a -> String
show Namespace
ns) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")/"
  case Maybe Documentation
doc of
    Maybe Documentation
Nothing -> () -> Output ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (Documentation String
d) ->
        do
          String -> Output ()
outStrLn String
"--"
          let ls :: [String]
ls = String -> [String]
lines String
d
          if [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 -- lame "longer docs" heuristic
          then (String -> Output ()) -> [String] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Output ()
outStrLn (String -> Output ()) -> (String -> String) -> String -> Output ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-- " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [String]
ls
          else do
            -- longer docs: head unformatted
            String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"-- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
ls
            -- explicit formatting for tail
            String -> Output ()
outStrLn String
"--"
            String -> Output ()
outStrLn String
"-- @"
            (String -> Output ()) -> [String] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Output ()
outStrLn (String -> Output ()) -> (String -> String) -> String -> Output ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"-- " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) ([String] -> [String]
forall a. [a] -> [a]
tail [String]
ls)
            String -> Output ()
outStrLn String
"-- @"
  Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$ do
    String -> Output ()
outStrLn String
""
    String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"-- mangled: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i


-- | Codegen a type.
outputType :: Type -> Output ()
outputType :: Type -> Output ()
outputType (BuiltIn {}) = () -> Output ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- NEWTYPE --
outputType nt :: Type
nt@(NewType {[Impl]
Maybe Documentation
Type
DerivesFamily
Name
_typeDoc :: Type -> Maybe Documentation
_typeImpls :: Type -> [Impl]
_typeDerives :: Type -> DerivesFamily
_typeType :: Type -> Type
_typeName :: Type -> Name
_typeDoc :: Maybe Documentation
_typeImpls :: [Impl]
_typeDerives :: DerivesFamily
_typeType :: Type
_typeName :: Name
..}) = do
  Name -> Maybe Documentation -> Output ()
header Name
_typeName Maybe Documentation
_typeDoc
  String
mn <- Type -> Output String
mangleType Type
nt
  String
mf <- Name -> String -> Int -> Output String
mangleField Name
_typeName String
"" Int
0
  String
rt <- Type -> Output String
refType Type
_typeType
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"newtype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
" { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    deriving (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DerivesFamily -> String
outputDerives DerivesFamily
_typeDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  (Impl -> Output ()) -> [Impl] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type -> Impl -> Output ()
outputImpls Type
nt) [Impl]
_typeImpls
  String -> Output ()
outputEmitXml String
mn
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    emitXml = emitXml . " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mf
  -- PARSING
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: String -> P.XParse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn
  if DerivesFamily
_typeDerives DerivesFamily -> DerivesFamily -> Bool
forall a. Eq a => a -> a -> Bool
== DerivesFamily
NewTypeString
  then String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = return . fromString"
  else String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = P.xread \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""


-- DATA --
outputType dt :: Type
dt@(DataType {[Impl]
[Ctor]
Maybe Documentation
DataTypeEmit
DerivesFamily
Name
_typeEmit :: Type -> DataTypeEmit
_typeCtors :: Type -> [Ctor]
_typeDoc :: Maybe Documentation
_typeEmit :: DataTypeEmit
_typeImpls :: [Impl]
_typeDerives :: DerivesFamily
_typeCtors :: [Ctor]
_typeName :: Name
_typeDoc :: Type -> Maybe Documentation
_typeImpls :: Type -> [Impl]
_typeDerives :: Type -> DerivesFamily
_typeName :: Type -> Name
..}) = do
  Name -> Maybe Documentation -> Output ()
header Name
_typeName Maybe Documentation
_typeDoc
  String
mn <- Type -> Output String
mangleType Type
dt
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "
  [(Int, Ctor)] -> ((Int, Ctor) -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Ctor] -> [(Int, Ctor)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [Ctor]
_typeCtors) (((Int, Ctor) -> Output ()) -> Output ())
-> ((Int, Ctor) -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,Ctor {String
[Field]
_ctorFields :: Ctor -> [Field]
_ctorName :: Ctor -> String
_ctorFields :: [Field]
_ctorName :: String
..}) ->
      do
        String -> Output ()
outStr (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then String
"    | " else String
"      ")
        Name -> String -> Output String
mangleCtor Name
_typeName String
_ctorName Output String -> (String -> Output ()) -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Output ()
outStr
        if [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field]
_ctorFields then String -> Output ()
outStrLn String
""
        else do
          String -> Output ()
outStrLn String
" {"
          [(Int, Field)] -> ((Int, Field) -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Field] -> [(Int, Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [Field]
_ctorFields) (((Int, Field) -> Output ()) -> Output ())
-> ((Int, Field) -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Int
j,Field QN
fn Type
ft Cardinality
fc FieldEmit
femit Int
fi) ->
            do
              String -> Output ()
outStr (if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then String
"        , " else String
"          ")
              String
rt <- Type -> Output String
refType Type
ft
              String
mf <- Name -> String -> Int -> Output String
mangleField Name
_typeName (QN -> String
_qLocal QN
fn) Int
fi
              let docs :: String
docs = if DataTypeEmit
_typeEmit DataTypeEmit -> DataTypeEmit -> Bool
forall a. Eq a => a -> a -> Bool
== DataTypeEmit
DataTypeSimple then String
""
                         else case FieldEmit
femit of
                           FieldEmit
FieldAttribute -> String
" -- ^ /" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/ attribute"
                           FieldEmit
FieldElement -> String
" -- ^ /" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/ child element"
                           FieldEmit
FieldText -> String
" -- ^ text content"
                           FieldEmit
FieldOther -> String
""

              String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
mf String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cardinality -> String -> String
card Cardinality
fc String
rt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
docs
          String -> Output ()
outStrLn String
"       }"
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    deriving (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DerivesFamily -> String
outputDerives DerivesFamily
_typeDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  -- EmitXml instance
  String -> Output ()
outputEmitXml String
mn
  [Ctor] -> (Ctor -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Ctor]
_typeCtors ((Ctor -> Output ()) -> Output ())
-> (Ctor -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Ctor {String
[Field]
_ctorFields :: [Field]
_ctorName :: String
_ctorFields :: Ctor -> [Field]
_ctorName :: Ctor -> String
..}) -> do
    String
mcn <- Name -> String -> Output String
mangleCtor Name
_typeName String
_ctorName
    case DataTypeEmit
_typeEmit of
      DataTypeEmit
DataTypeSimple ->
          String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    emitXml (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" a) = emitXml a"
      DataTypeEmit
_ -> do
        let fas :: [(String, Field)]
fas = [String] -> [Field] -> [(String, Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fieldArgs [Field]
_ctorFields
            genEls :: [(String, Field)] -> String
genEls [] = String
"[]"
            genEls [(String, Field)]
es = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ++\n        "
                        (((String, Field) -> String) -> [(String, Field)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String, Field)
f -> FieldEmit -> (String, Field) -> String
genEl (Field -> FieldEmit
_fieldXmlEmit ((String, Field) -> Field
forall a b. (a, b) -> b
snd (String, Field)
f)) (String, Field)
f) [(String, Field)]
es) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            genEl :: FieldEmit -> (String, Field) -> String
genEl FieldEmit
FieldElement (String, Field)
f = String -> (String, Field) -> String
genPart String
"XElement" (String, Field)
f
            genEl FieldEmit
FieldOther (String
c,Field
_) = String
"[emitXml " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
            genEl FieldEmit
_ (String, Field)
f = String -> String
forall a. HasCallStack => String -> a
error String
"c'est impossible: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, Field) -> String
forall a. Show a => a -> String
show (String, Field)
f
            genParts :: String -> [(String, Field)] -> String
genParts String
_ [] = String
"[]"
            genParts String
xctor [(String, Field)]
ffs = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ++\n        " (((String, Field) -> String) -> [(String, Field)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (String, Field) -> String
genPart String
xctor) [(String, Field)]
ffs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            genPart :: String -> (String, Field) -> String
genPart String
xctor (String
c,Field QN
fn Type
_ Cardinality
fc FieldEmit
_ Int
_) =
                case Cardinality
fc of
                  Cardinality
One -> String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> QN -> String
genct String
xctor QN
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (emitXml " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")]"
                  Cardinality
ZeroOrOne -> String
"[maybe XEmpty (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> QN -> String
genct String
xctor QN
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".emitXml) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
                  Cardinality
Many -> String
"map (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> QN -> String
genct String
xctor QN
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".emitXml) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c
            genct :: String -> QN -> String
genct String
x QN
q = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QN -> String
genqn QN
q
            genqn :: QN -> String
genqn (QN String
l Maybe String
p) = String
"(QN \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Nothing" (\String
v -> String
"(Just \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")") Maybe String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             String
")"
            genreps :: [(String, b)] -> String
genreps [(String, b)]
ffs = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((String, b) -> String) -> [(String, b)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"emitXml "String -> String -> String
forall a. [a] -> [a] -> [a]
++)(String -> String)
-> ((String, b) -> String) -> (String, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, b) -> String
forall a b. (a, b) -> a
fst) [(String, b)]
ffs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
            findFields :: (FieldEmit -> Bool) -> [(String, Field)]
findFields FieldEmit -> Bool
fpred = ((String, Field) -> Bool) -> [(String, Field)] -> [(String, Field)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FieldEmit -> Bool
fpred (FieldEmit -> Bool)
-> ((String, Field) -> FieldEmit) -> (String, Field) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> FieldEmit
_fieldXmlEmit (Field -> FieldEmit)
-> ((String, Field) -> Field) -> (String, Field) -> FieldEmit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Field) -> Field
forall a b. (a, b) -> b
snd) [(String, Field)]
fas
            oths :: [(String, Field)]
oths = (FieldEmit -> Bool) -> [(String, Field)]
findFields (FieldEmit -> FieldEmit -> Bool
forall a. Eq a => a -> a -> Bool
==FieldEmit
FieldOther)
        String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    emitXml (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((String, Field) -> String) -> [(String, Field)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((String, Field) -> String) -> (String, Field) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Field) -> String
forall a b. (a, b) -> a
fst) [(String, Field)]
fas  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ="
        if [(String, Field)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Field)]
oths Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(String, Field)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Field)]
fas  -- heuristic for "passthrough" compositors
        then do
          Int -> Output ()
indent Int
6
          if Impl
TopLevel Impl -> [Impl] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Impl]
_typeImpls
          then String -> Output ()
outStr (String
"XElement " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QN -> String
genqn (Name -> QN
nName Name
_typeName) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ XContent ")
          else String -> Output ()
outStr String
"XContent "
          case ((String, Field) -> String) -> [(String, Field)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Field) -> String
forall a b. (a, b) -> a
fst ([(String, Field)] -> [String]) -> [(String, Field)] -> [String]
forall a b. (a -> b) -> a -> b
$ (FieldEmit -> Bool) -> [(String, Field)]
findFields (FieldEmit -> FieldEmit -> Bool
forall a. Eq a => a -> a -> Bool
==FieldEmit
FieldText) of
            [String
c] -> String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"(emitXml " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            [] -> String -> Output ()
outStrLn String
"XEmpty"
            [String]
_ -> String -> Output ()
forall (m :: * -> *) a. MonadIO m => String -> m a
die (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"More than one text field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
dt
          Int -> Output ()
indent Int
8 Output () -> Output () -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Output ()
outStrLn (String -> [(String, Field)] -> String
genParts String
"XAttr" ((FieldEmit -> Bool) -> [(String, Field)]
findFields (FieldEmit -> FieldEmit -> Bool
forall a. Eq a => a -> a -> Bool
==FieldEmit
FieldAttribute)))
          Int -> Output ()
indent Int
8 Output () -> Output () -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Output ()
outStrLn ([(String, Field)] -> String
genEls ((FieldEmit -> Bool) -> [(String, Field)]
findFields (FieldEmit -> [FieldEmit] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldEmit
FieldElement,FieldEmit
FieldOther])))

        else
          Int -> Output ()
indent Int
6 Output () -> Output () -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Output ()
outStrLn (String
"XReps " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, Field)] -> String
forall b. [(String, b)] -> String
genreps [(String, Field)]
fas)
  -- PARSING

  if DataTypeEmit
_typeEmit DataTypeEmit -> DataTypeEmit -> Bool
forall a. Eq a => a -> a -> Bool
== DataTypeEmit
DataTypeSimple
  then do
    String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: String -> P.XParse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn
    String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s = "
  else do
    String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: P.XParse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn
    String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "
  [(Int, Ctor)] -> ((Int, Ctor) -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Ctor] -> [(Int, Ctor)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [Ctor]
_typeCtors) (((Int, Ctor) -> Output ()) -> Output ())
-> ((Int, Ctor) -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Int
j,Ctor {String
[Field]
_ctorFields :: [Field]
_ctorName :: String
_ctorFields :: Ctor -> [Field]
_ctorName :: Ctor -> String
..}) -> do
    String
mcn <- Name -> String -> Output String
mangleCtor Name
_typeName String
_ctorName
    String -> Output ()
outStr String
"      "
    Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$ String -> Output ()
outStr String
"<|> "
    if [Field] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field]
_ctorFields
    then String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn
    else String -> Output ()
outStrLn String
mcn
    [(Int, Field)] -> ((Int, Field) -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Field] -> [(Int, Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int) ..] [Field]
_ctorFields) (((Int, Field) -> Output ()) -> Output ())
-> ((Int, Field) -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,Field {Int
QN
Type
FieldEmit
Cardinality
_fieldIdx :: Field -> Int
_fieldCardinality :: Field -> Cardinality
_fieldType :: Field -> Type
_fieldName :: Field -> QN
_fieldIdx :: Int
_fieldXmlEmit :: FieldEmit
_fieldCardinality :: Cardinality
_fieldType :: Type
_fieldName :: QN
_fieldXmlEmit :: Field -> FieldEmit
..}) ->
      do
        String -> Output ()
outStr (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"        " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"<$> " else String
"<*> ")
        String
ftn <- Type -> Output String
mangleType Type
_fieldType
        case DataTypeEmit
_typeEmit of
          DataTypeEmit
DataTypeSimple -> String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String -> String
parseFun String
ftn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s"
          DataTypeEmit
_ ->
            do
              let pname :: String
pname = String
"(P.name \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
_fieldName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")"
                  parser :: String
parser = String -> String
parseFun String
ftn
                  attrParse :: String
attrParse = String
"(P.xattr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                  elParse :: String
elParse = String -> String -> Type -> String
parseEl String
parser String
pname Type
_fieldType
                  -- gross heuristic to handle horrible musicxml things
                  pmany :: String
pmany | [Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
_ctorFields Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& [Ctor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ctor]
_typeCtors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = String
"P.some"
                        | Bool
otherwise = String
"P.many"
              String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ case (FieldEmit
_fieldXmlEmit,Cardinality
_fieldCardinality) of
                (FieldEmit
FieldAttribute,Cardinality
ZeroOrOne) -> String
"P.optional " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
attrParse
                (FieldEmit
FieldAttribute,Cardinality
_) -> String
attrParse
                (FieldEmit
FieldText,Cardinality
_) -> String
"(P.xtext >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                (FieldEmit
FieldElement,Cardinality
Many) -> String
pmany String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
elParse
                (FieldEmit
FieldElement,Cardinality
ZeroOrOne) -> String
"P.optional " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
elParse
                (FieldEmit
FieldElement,Cardinality
One) -> String
elParse
                (FieldEmit
FieldOther,Cardinality
ZeroOrOne) -> String
"P.optional (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                (FieldEmit
FieldOther,Cardinality
Many) -> String
"P.many (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                (FieldEmit
FieldOther,Cardinality
_) -> String
parser


  String -> Output ()
outStrLn String
""
  -- smart ctors
  Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DataTypeEmit
_typeEmit DataTypeEmit -> DataTypeEmit -> Bool
forall a. Eq a => a -> a -> Bool
== DataTypeEmit
DataTypeSimple) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$
         [Ctor] -> (Ctor -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Ctor]
_typeCtors ((Ctor -> Output ()) -> Output ())
-> (Ctor -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Ctor {String
[Field]
_ctorFields :: [Field]
_ctorName :: String
_ctorFields :: Ctor -> [Field]
_ctorName :: Ctor -> String
..}) ->
           do
             String
mcn <- Name -> String -> Output String
mangleCtor Name
_typeName String
_ctorName
             let fas :: [(String, Field)]
fas = [String] -> [Field] -> [(String, Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fieldArgs [Field]
_ctorFields
             [(String, Maybe (String, String))]
mfs <- [(String, Field)]
-> ((String, Field)
    -> ReaderT
         OutputEnv (StateT OutputState IO) (String, Maybe (String, String)))
-> ReaderT
     OutputEnv
     (StateT OutputState IO)
     [(String, Maybe (String, String))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Field)]
fas (((String, Field)
  -> ReaderT
       OutputEnv (StateT OutputState IO) (String, Maybe (String, String)))
 -> ReaderT
      OutputEnv
      (StateT OutputState IO)
      [(String, Maybe (String, String))])
-> ((String, Field)
    -> ReaderT
         OutputEnv (StateT OutputState IO) (String, Maybe (String, String)))
-> ReaderT
     OutputEnv
     (StateT OutputState IO)
     [(String, Maybe (String, String))]
forall a b. (a -> b) -> a -> b
$ \(String
c,Field QN
_ Type
ft Cardinality
fc FieldEmit
_ Int
_) ->
                     case Cardinality
fc of
                       Cardinality
One -> (String
c,) (Maybe (String, String) -> (String, Maybe (String, String)))
-> (String -> Maybe (String, String))
-> String
-> (String, Maybe (String, String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> Maybe (String, String))
-> (String -> (String, String)) -> String -> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c,) (String -> (String, Maybe (String, String)))
-> Output String
-> ReaderT
     OutputEnv (StateT OutputState IO) (String, Maybe (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Output String
refType Type
ft
                       Cardinality
ZeroOrOne -> (String, Maybe (String, String))
-> ReaderT
     OutputEnv (StateT OutputState IO) (String, Maybe (String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Nothing",Maybe (String, String)
forall a. Maybe a
Nothing)
                       Cardinality
Many -> (String, Maybe (String, String))
-> ReaderT
     OutputEnv (StateT OutputState IO) (String, Maybe (String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"[]",Maybe (String, String)
forall a. Maybe a
Nothing)
             let args :: [(String, String)]
args = ((String, Maybe (String, String)) -> Maybe (String, String))
-> [(String, Maybe (String, String))] -> [(String, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String, Maybe (String, String)) -> Maybe (String, String)
forall a b. (a, b) -> b
snd [(String, Maybe (String, String))]
mfs
             String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"-- | Smart constructor for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
             String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"mk" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> ") (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd) [(String, String)]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn
             String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"mk" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
"= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mcn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (((String, Maybe (String, String)) -> String)
-> [(String, Maybe (String, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe (String, String)) -> String
forall a b. (a, b) -> a
fst [(String, Maybe (String, String))]
mfs)
  (Impl -> Output ()) -> [Impl] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type -> Impl -> Output ()
outputImpls Type
dt) [Impl]
_typeImpls


-- ENUM --
outputType et :: Type
et@(EnumType {[String]
[Impl]
Maybe Documentation
DerivesFamily
Name
_typeEnumValues :: Type -> [String]
_typeDoc :: Maybe Documentation
_typeImpls :: [Impl]
_typeDerives :: DerivesFamily
_typeEnumValues :: [String]
_typeName :: Name
_typeDoc :: Type -> Maybe Documentation
_typeImpls :: Type -> [Impl]
_typeDerives :: Type -> DerivesFamily
_typeName :: Type -> Name
..}) = do
  Name -> Maybe Documentation -> Output ()
header Name
_typeName Maybe Documentation
_typeDoc
  String
mn <- Type -> Output String
mangleType Type
et
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "
  [(Int, String)] -> ((Int, String) -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [String]
_typeEnumValues) (((Int, String) -> Output ()) -> Output ())
-> ((Int, String) -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,String
s) ->
      do
        String -> Output ()
outStr (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then String
"    | " else String
"      ")
        Name -> String -> Output String
mangleCtor Name
_typeName String
s Output String -> (String -> Output ()) -> Output ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
e -> String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- ^ /" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    deriving (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DerivesFamily -> String
outputDerives DerivesFamily
_typeDerives  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  (Impl -> Output ()) -> [Impl] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type -> Impl -> Output ()
outputImpls Type
et) [Impl]
_typeImpls
  String -> Output ()
outputEmitXml String
mn
  [String] -> (String -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
_typeEnumValues ((String -> Output ()) -> Output ())
-> (String -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \String
s -> do
    String
cn <- Name -> String -> Output String
mangleCtor Name
_typeName String
s
    String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"    emitXml " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = XLit \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
  -- PARSING
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: String -> P.XParse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s"
  [String] -> (String -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_  [String]
_typeEnumValues ((String -> Output ()) -> Output ())
-> (String -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
      do
        String
cn <- Name -> String -> Output String
mangleCtor Name
_typeName String
s
        String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"        | s == \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" = return $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cn
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"        | otherwise = P.xfail $ \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": \" ++ s"


-- | breaking off because RecordWildCards breaks haskell
parseEl :: String -> String -> Type -> String
parseEl :: String -> String -> Type -> String
parseEl String
parser String
pname Type
fType =
    case Getting (Leftmost DataTypeEmit) Type DataTypeEmit
-> Type -> Maybe DataTypeEmit
forall a s. Getting (Leftmost a) s a -> s -> Maybe a
firstOf Getting (Leftmost DataTypeEmit) Type DataTypeEmit
Traversal' Type DataTypeEmit
typeEmit Type
fType of
      Just DataTypeEmit
DataTypeSimple -> String
simpleEl
      Maybe DataTypeEmit
Nothing -> String
simpleEl
      Maybe DataTypeEmit
_ -> String
"(P.xchild " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
    where simpleEl :: String
simpleEl = String
"(P.xchild " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (P.xtext >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parser String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"

parseFun :: String -> String
parseFun :: String -> String
parseFun String
tn | String
tn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Decimal" = String
rp
            | String
tn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"DefString" = String
"return"
            | String
tn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Integer" = String
rp
            | Bool
otherwise = String
"parse" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn
            where rp :: String
rp = String
"(P.xread \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")"

-- | List of usable field arguments.
fieldArgs :: [String]
fieldArgs :: [String]
fieldArgs = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
p -> (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
p)(String -> String) -> (Char -> String) -> Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Char
'a'..Char
'z']) (String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
'1'..Char
'9'])

-- | Begin an EmitXml instance.
outputEmitXml :: String -> Output ()
outputEmitXml :: String -> Output ()
outputEmitXml String
typename =
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"instance EmitXml " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"

-- | Codegen for cardinality (Maybe or List).
card :: Cardinality -> String -> String
card :: Cardinality -> String -> String
card Cardinality
One String
s = String
s
card Cardinality
ZeroOrOne String
s = String
"(Maybe " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
card Cardinality
Many String
s = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

-- | Mangling for type names.
mangleType :: Type -> Output String
mangleType :: Type -> Output String
mangleType = Name -> Output String
m (Name -> Output String) -> (Type -> Name) -> Type -> Output String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Name
_typeName where
    m :: Name -> Output String
m n :: Name
n@(Name Namespace
_ QN
bare Int
_) = Name -> String -> (String -> String) -> Output String
mangle Name
n (String -> String
firstUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
fixChars (QN -> String
_qLocal QN
bare)) String -> String
firstUpper


-- | Run mangling rules.
mangle :: Name -> String -> (String -> String) -> Output String
mangle :: Name -> String -> (String -> String) -> Output String
mangle n :: Name
n@(Name Namespace
ns QN
_ Int
i) String
tname String -> String
mangledFun =
  Name -> String -> Output String -> Output String
tryName Name
n String
tname (Output String -> Output String) -> Output String -> Output String
forall a b. (a -> b) -> a -> b
$ do
    let pfx :: Namespace -> p
pfx Namespace
NSBuiltIn = p
"Def"
        pfx Namespace
NSComplex = p
"Cmp"
        pfx Namespace
NSUnion = p
"Sum"
        pfx Namespace
NSSimple = p
"Smp"
        pfx Namespace
NSElement = p
"El"
        pfx Namespace
NSChoice = p
"Chx"
        pfx Namespace
NSSequence = p
"Seq"
        pfx Namespace
NSGroup = p
"Grp"
        tnameP :: String
tnameP = String -> String
mangledFun (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Namespace -> String
forall p. IsString p => Namespace -> p
pfx Namespace
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tname
    Name -> String -> Output String -> Output String
tryName Name
n String
tnameP (Output String -> Output String) -> Output String -> Output String
forall a b. (a -> b) -> a -> b
$ do
                    let tnamei :: String
tnamei = String
tnameP String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
                    Name -> String -> Output String -> Output String
tryName Name
n String
tnamei (Output String -> Output String) -> Output String -> Output String
forall a b. (a -> b) -> a -> b
$
                            String -> Output String
forall (m :: * -> *) a. MonadIO m => String -> m a
die (String -> Output String) -> String -> Output String
forall a b. (a -> b) -> a -> b
$ String
"type already exists for mangled name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tnamei

-- | Check if name exists, if not register it.
tryName :: Name -> String -> Output String -> Output String
tryName :: Name -> String -> Output String -> Output String
tryName Name
n String
tn Output String
ifnot = do
  Maybe Name
fn <- String -> Map String Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
tn (Map String Name -> Maybe Name)
-> ReaderT OutputEnv (StateT OutputState IO) (Map String Name)
-> ReaderT OutputEnv (StateT OutputState IO) (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Map String Name) OutputState (Map String Name)
-> ReaderT OutputEnv (StateT OutputState IO) (Map String Name)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Map String Name) OutputState (Map String Name)
Iso' OutputState (Map String Name)
names
  case Maybe Name
fn of
    Maybe Name
Nothing -> do
            (Map String Name -> Identity (Map String Name))
-> OutputState -> Identity OutputState
Iso' OutputState (Map String Name)
names ((Map String Name -> Identity (Map String Name))
 -> OutputState -> Identity OutputState)
-> (Map String Name -> Map String Name) -> Output ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= String -> Name -> Map String Name -> Map String Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
tn Name
n
            String -> Output String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tn
    (Just Name
found)
        | Name
found Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n -> String -> Output String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tn
        | Bool
otherwise -> Output String
ifnot

-- | Type/Ctor naming.
firstUpper :: String -> String
firstUpper :: String -> String
firstUpper (Char
s:String
ss) = Char -> Char
toUpper Char
sChar -> String -> String
forall a. a -> [a] -> [a]
:String
ss
firstUpper [] = []
-- | Field naming.
firstLower :: String -> String
firstLower :: String -> String
firstLower (Char
s:String
ss) = Char -> Char
toLower Char
sChar -> String -> String
forall a. a -> [a] -> [a]
:String
ss
firstLower [] = []

-- | Mangling for fields.
mangleField :: Name -> String -> Int -> Output String
mangleField :: Name -> String -> Int -> Output String
mangleField Name
nm String
n Int
i = Name -> String -> (String -> String) -> Output String
mangle Name
nm
                     (String -> String
firstLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
fixChars (QN -> String
_qLocal (Name -> QN
nName Name
nm) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
firstUpper String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> String
forall a. Show a => a -> String
show Int
i else String
""))
                     String -> String
firstLower

-- | Mangling for ctors.
mangleCtor :: Name -> String -> Output String
mangleCtor :: Name -> String -> Output String
mangleCtor Name
nm String
n = Name -> String -> (String -> String) -> Output String
mangle Name
nm (String -> String
firstUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
fixChars (QN -> String
_qLocal (Name -> QN
nName Name
nm) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
firstUpper String
n)) String -> String
firstUpper

-- | Substitute valid Haskell chars.
fixChars :: String -> String
fixChars :: String -> String
fixChars = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> String
forall a b. (a, b) -> b
snd ((Bool, String) -> String)
-> (String -> (Bool, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, String) -> Char -> (Bool, String))
-> (Bool, String) -> String -> (Bool, String)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Bool, String) -> Char -> (Bool, String)
fc (Bool
True,String
"")
    where fc :: (Bool, String) -> Char -> (Bool, String)
fc (Bool
uc,String
s) Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"- :" :: String) = (Bool
True,String
s)
                      | Bool
otherwise = (Bool
False,(if Bool
uc then Char -> Char
toUpper Char
c else Char
c)Char -> String -> String
forall a. a -> [a] -> [a]
:String
s)

-- | Get referred type name, handling builtins.
refType :: Type -> Output String
refType :: Type -> Output String
refType t :: Type
t@(BuiltIn {}) = String -> Output String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Output String) -> String -> Output String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CoreType -> String
forall a. Show a => a -> String
show (Type -> CoreType
_coreType Type
t)
refType Type
t = Type -> Output String
mangleType Type
t

-- | Output derive types.
outputDerives :: DerivesFamily -> String
outputDerives :: DerivesFamily -> String
outputDerives DerivesFamily
NewTypeIntegral = String
allDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Ord,Bounded,Enum,Num,Real,Integral"
outputDerives DerivesFamily
NewTypeNum = String
allDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Ord,Num,Real,Fractional,RealFrac"
outputDerives DerivesFamily
NewTypeString = String
allDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Ord,IsString"
outputDerives DerivesFamily
OtherDerives = String
allDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Show"
outputDerives DerivesFamily
DataEnum = String
allDerives String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Show,Ord,Enum,Bounded"

-- | Common derived types.
allDerives :: String
allDerives :: String
allDerives = String
"Eq,Typeable,Generic,"

-- | Handle impls.
-- | TODO patterns, bounds.
outputImpls :: Type -> Impl -> Output ()
outputImpls :: Type -> Impl -> Output ()
outputImpls Type
t Impl
NewTypeShow = do
  String
tn <- Type -> Output String
refType Type
t
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"instance Show " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where show (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" a) = show a"
  String -> Output ()
outStrLn (String -> Output ()) -> String -> Output ()
forall a b. (a -> b) -> a -> b
$ String
"instance Read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where readsPrec i = map (A.first " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") . readsPrec i"
outputImpls Type
_ Impl
_ = () -> Output ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Output pragmas, module, imports.
outputHeader :: String -> Output ()
outputHeader :: String -> Output ()
outputHeader String
moduleName = (String -> Output ()) -> [String] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Output ()
outStrLn
    [ String
"{-# LANGUAGE TupleSections #-}"
    , String
"{-# LANGUAGE DeriveGeneric #-}"
    , String
"{-# LANGUAGE FlexibleContexts #-}"
    , String
"{-# LANGUAGE DeriveDataTypeable #-}"
    , String
"{-# LANGUAGE TemplateHaskell #-}"
    , String
"{-# LANGUAGE OverloadedStrings #-}"
    , String
"{-# LANGUAGE GeneralizedNewtypeDeriving #-}"
    , String
"{-# LANGUAGE DeriveDataTypeable #-}"
    , String
"{-# LANGUAGE MultiParamTypeClasses #-}"
    , String
""
    , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
    , String
""
    , String
"import GHC.Generics"
    , String
"import Data.Data"
    , String
"import Data.Decimal"
    , String
"import Data.String"
    , String
"import Fadno.Xml.EmitXml"
    , String
"import qualified Fadno.Xml.XParse as P"
    , String
"import qualified Control.Applicative as P"
    , String
"import Control.Applicative ((<|>))"
    , String
"import qualified Control.Arrow as A"
    ]