{-# 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
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 [Char] 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 [Char] Name
defaultNames = [([Char], Name)] -> Map [Char] Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([([Char], Name)] -> Map [Char] Name)
-> [([Char], Name)] -> Map [Char] Name
forall a b. (a -> b) -> a -> b
$ ([Char] -> ([Char], Name)) -> [[Char]] -> [([Char], Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
n -> ([Char]
n,Namespace -> QN -> Int -> Name
Name Namespace
NSBuiltIn ([Char] -> Maybe [Char] -> QN
QN [Char]
n Maybe [Char]
forall a. Maybe a
Nothing) Int
0))
               [[Char]
"Eq",[Char]
"Typeable",[Char]
"Generic",[Char]
"Ord",[Char]
"Bounded",
                [Char]
"Enum",[Char]
"Num",[Char]
"Real",[Char]
"Integral",[Char]
"Show",
               [Char]
"String",[Char]
"Double",[Char]
"Float",[Char]
"Boolean",[Char]
"Int"]

-- | Run output monad.
runOut :: OutputEnv -> OutputState -> Output a -> IO (a, OutputState)
runOut :: forall a.
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' :: forall a. 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 [Char] Name -> OutputState
OutputState Map [Char] Name
defaultNames)

-- | putStr in codegen.
outStr :: String -> Output ()
outStr :: [Char] -> Output ()
outStr [Char]
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 a b.
ReaderT OutputEnv (StateT OutputState IO) a
-> (a -> ReaderT OutputEnv (StateT OutputState IO) b)
-> ReaderT OutputEnv (StateT OutputState IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> IO () -> Output ()
forall a. IO a -> ReaderT OutputEnv (StateT OutputState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Output ()) -> IO () -> Output ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStr Handle
h [Char]
s

-- | putStrLn in codegen.
outStrLn :: String -> Output ()
outStrLn :: [Char] -> Output ()
outStrLn [Char]
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 a b.
ReaderT OutputEnv (StateT OutputState IO) a
-> (a -> ReaderT OutputEnv (StateT OutputState IO) b)
-> ReaderT OutputEnv (StateT OutputState IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> IO () -> Output ()
forall a. IO a -> ReaderT OutputEnv (StateT OutputState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Output ()) -> IO () -> Output ()
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
h [Char]
s

-- | indent.
indent :: Int -> Output ()
indent :: Int -> Output ()
indent Int
i = [Char] -> Output ()
outStr ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
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
  [Char] -> Output ()
outStrLn [Char]
""
  [Char] -> Output ()
outStr ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"-- | @" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QN -> [Char]
forall a. Show a => a -> [Char]
show QN
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"@"
  [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
" /(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
2 ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Namespace -> [Char]
forall a. Show a => a -> [Char]
show Namespace
ns) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")/"
  case Maybe Documentation
doc of
    Maybe Documentation
Nothing -> () -> Output ()
forall a. a -> ReaderT OutputEnv (StateT OutputState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (Documentation [Char]
d) ->
        do
          [Char] -> Output ()
outStrLn [Char]
"--"
          let ls :: [[Char]]
ls = [Char] -> [[Char]]
lines [Char]
d
          if [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 -- lame "longer docs" heuristic
          then ([Char] -> Output ()) -> [[Char]] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> Output ()
outStrLn ([Char] -> Output ()) -> ([Char] -> [Char]) -> [Char] -> Output ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"-- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) [[Char]]
ls
          else do
            -- longer docs: head unformatted
            [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"-- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
ls
            -- explicit formatting for tail
            [Char] -> Output ()
outStrLn [Char]
"--"
            [Char] -> Output ()
outStrLn [Char]
"-- @"
            ([Char] -> Output ()) -> [[Char]] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> Output ()
outStrLn ([Char] -> Output ()) -> ([Char] -> [Char]) -> [Char] -> Output ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"-- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) ([[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail [[Char]]
ls)
            [Char] -> Output ()
outStrLn [Char]
"-- @"
  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
    [Char] -> Output ()
outStrLn [Char]
""
    [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"-- mangled: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i


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

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


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

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

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


  [Char] -> Output ()
outStrLn [Char]
""
  -- 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 {[Char]
[Field]
_ctorName :: Ctor -> [Char]
_ctorFields :: Ctor -> [Field]
_ctorName :: [Char]
_ctorFields :: [Field]
..}) ->
           do
             [Char]
mcn <- Name -> [Char] -> Output [Char]
mangleCtor Name
_typeName [Char]
_ctorName
             let fas :: [([Char], Field)]
fas = [[Char]] -> [Field] -> [([Char], Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
fieldArgs [Field]
_ctorFields
             [([Char], Maybe ([Char], [Char]))]
mfs <- [([Char], Field)]
-> (([Char], Field)
    -> ReaderT
         OutputEnv (StateT OutputState IO) ([Char], Maybe ([Char], [Char])))
-> ReaderT
     OutputEnv
     (StateT OutputState IO)
     [([Char], Maybe ([Char], [Char]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Field)]
fas ((([Char], Field)
  -> ReaderT
       OutputEnv (StateT OutputState IO) ([Char], Maybe ([Char], [Char])))
 -> ReaderT
      OutputEnv
      (StateT OutputState IO)
      [([Char], Maybe ([Char], [Char]))])
-> (([Char], Field)
    -> ReaderT
         OutputEnv (StateT OutputState IO) ([Char], Maybe ([Char], [Char])))
-> ReaderT
     OutputEnv
     (StateT OutputState IO)
     [([Char], Maybe ([Char], [Char]))]
forall a b. (a -> b) -> a -> b
$ \([Char]
c,Field QN
_ Type
ft Cardinality
fc FieldEmit
_ Int
_) ->
                     case Cardinality
fc of
                       Cardinality
One -> ([Char]
c,) (Maybe ([Char], [Char]) -> ([Char], Maybe ([Char], [Char])))
-> ([Char] -> Maybe ([Char], [Char]))
-> [Char]
-> ([Char], Maybe ([Char], [Char]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just (([Char], [Char]) -> Maybe ([Char], [Char]))
-> ([Char] -> ([Char], [Char])) -> [Char] -> Maybe ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
c,) ([Char] -> ([Char], Maybe ([Char], [Char])))
-> Output [Char]
-> ReaderT
     OutputEnv (StateT OutputState IO) ([Char], Maybe ([Char], [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Output [Char]
refType Type
ft
                       Cardinality
ZeroOrOne -> ([Char], Maybe ([Char], [Char]))
-> ReaderT
     OutputEnv (StateT OutputState IO) ([Char], Maybe ([Char], [Char]))
forall a. a -> ReaderT OutputEnv (StateT OutputState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"Nothing",Maybe ([Char], [Char])
forall a. Maybe a
Nothing)
                       Cardinality
Many -> ([Char], Maybe ([Char], [Char]))
-> ReaderT
     OutputEnv (StateT OutputState IO) ([Char], Maybe ([Char], [Char]))
forall a. a -> ReaderT OutputEnv (StateT OutputState IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"[]",Maybe ([Char], [Char])
forall a. Maybe a
Nothing)
             let args :: [([Char], [Char])]
args = (([Char], Maybe ([Char], [Char])) -> Maybe ([Char], [Char]))
-> [([Char], Maybe ([Char], [Char]))] -> [([Char], [Char])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char], Maybe ([Char], [Char])) -> Maybe ([Char], [Char])
forall a b. (a, b) -> b
snd [([Char], Maybe ([Char], [Char]))]
mfs
             [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"-- | Smart constructor for '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mcn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
             [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mcn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> ") ([Char] -> [Char])
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd) [([Char], [Char])]
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mn
             [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mcn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ") ([Char] -> [Char])
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], [Char])]
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
"= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mcn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((([Char], Maybe ([Char], [Char])) -> [Char])
-> [([Char], Maybe ([Char], [Char]))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Maybe ([Char], [Char])) -> [Char]
forall a b. (a, b) -> a
fst [([Char], Maybe ([Char], [Char]))]
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 {[[Char]]
[Impl]
Maybe Documentation
DerivesFamily
Name
_typeName :: Type -> Name
_typeDerives :: Type -> DerivesFamily
_typeImpls :: Type -> [Impl]
_typeDoc :: Type -> Maybe Documentation
_typeName :: Name
_typeEnumValues :: [[Char]]
_typeDerives :: DerivesFamily
_typeImpls :: [Impl]
_typeDoc :: Maybe Documentation
_typeEnumValues :: Type -> [[Char]]
..}) = do
  Name -> Maybe Documentation -> Output ()
header Name
_typeName Maybe Documentation
_typeDoc
  [Char]
mn <- Type -> Output [Char]
mangleType Type
et
  [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"data " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = "
  [(Int, [Char])] -> ((Int, [Char]) -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [[Char]] -> [(Int, [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [[Char]]
_typeEnumValues) (((Int, [Char]) -> Output ()) -> Output ())
-> ((Int, [Char]) -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,[Char]
s) ->
      do
        [Char] -> Output ()
outStr (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Char]
"    | " else [Char]
"      ")
        Name -> [Char] -> Output [Char]
mangleCtor Name
_typeName [Char]
s Output [Char] -> ([Char] -> Output ()) -> Output ()
forall a b.
ReaderT OutputEnv (StateT OutputState IO) a
-> (a -> ReaderT OutputEnv (StateT OutputState IO) b)
-> ReaderT OutputEnv (StateT OutputState IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
e -> [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -- ^ /" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/"
  [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    deriving (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DerivesFamily -> [Char]
outputDerives DerivesFamily
_typeDerives  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  (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
  [Char] -> Output ()
outputEmitXml [Char]
mn
  [[Char]] -> ([Char] -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
_typeEnumValues (([Char] -> Output ()) -> Output ())
-> ([Char] -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s -> do
    [Char]
cn <- Name -> [Char] -> Output [Char]
mangleCtor Name
_typeName [Char]
s
    [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"    emitXml " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = XLit \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
  -- PARSING
  [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parse" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: String -> P.XParse " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mn
  [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"parse" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" s"
  [[Char]] -> ([Char] -> Output ()) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_  [[Char]]
_typeEnumValues (([Char] -> Output ()) -> Output ())
-> ([Char] -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
      do
        [Char]
cn <- Name -> [Char] -> Output [Char]
mangleCtor Name
_typeName [Char]
s
        [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"        | s == \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" = return $ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cn
  [Char] -> Output ()
outStrLn ([Char] -> Output ()) -> [Char] -> Output ()
forall a b. (a -> b) -> a -> b
$ [Char]
"        | otherwise = P.xfail $ \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": \" ++ s"


-- | breaking off because RecordWildCards breaks haskell
parseEl :: String -> String -> Type -> String
parseEl :: [Char] -> [Char] -> Type -> [Char]
parseEl [Char]
parser [Char]
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 -> [Char]
simpleEl
      Maybe DataTypeEmit
Nothing -> [Char]
simpleEl
      Maybe DataTypeEmit
_ -> [Char]
"(P.xchild " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
parser [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))"
    where simpleEl :: [Char]
simpleEl = [Char]
"(P.xchild " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (P.xtext >>= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
parser [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"))"

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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