[c] -> text "parseContents = do"
$$ nest 4 (text "{ inElementWith (flip isPrefixOf)"
<+> text (show (constructor c)) <+> text "$"
$$ parseFn True (head cvs) c
_ -> text "parseContents = do"
$$ nest 4 (text "{ e@(Elem t _ _) <- elementWith (flip isPrefixOf)"
<+> text (show (preorder cs (map constructor cs)))
$$ nest 2 (vcat (preorder cs
: zipWith3 showsfn [0 ..] cvs cs)
toHTfn :: [Body] -> [[Doc]] -> Data -> Doc
pats = concat (zipWith mkpat cvs cs)
fsep [ text "\"" <> text typ <> text "\""
, bracketList (map text fvs)
, bracketList (zipWith toConstr cvs cs)
else nest 2 (text "where") $$
nest 4 (vcat (map (<+> text "= v") pats)) $$
nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs))
[text [x, y] | x <- ['a' .. 'z'], y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
mknss :: [Body] -> [a] -> [[a]]
let (thisns, rest) = splitAt (length (types c)) ns
in thisns : mknss cs rest
mkpat :: [Doc] -> Body -> [Doc]
else [mypattern (constructor c) (types c) ns]
toConstr :: [Doc] -> Body -> Doc
fvs = nub (concatMap deepvars ts)
fsep [ text "\"" <> text cn <> text "\""
, bracketList (map text fvs)
, bracketList (map (text "toHType" <+>) ns)
deepvars (Arrow _ _) = []
-- deepvars (Apply t1 t2) = deepvars t1 ++ deepvars t2
deepvars (LApply _ ts) = concatMap deepvars ts
deepvars (Tuple ts) = concatMap deepvars ts
deepvars (List t) = deepvars t
simplest :: String -> [([Doc], Body)] -> String -> Doc
let npats = [ (depth, (n, pat)) | (ns, c) <- cs
, (n, t) <- zip ns (types c)
, (depth, pat) <- [ findT fv t ]
foldl closest (Nothing, error "free tyvar not found") npats
parens rpat <+> text "= toHType" <+> r
findT :: String -> Type -> (Maybe Int, Doc)
| c == Con typ -> (Nothing, text "_")
$ cpat <+> bracketList (map (snd . uncurry perhaps) dpats)
Var s -> perhaps (if v == s then Just 0 else Nothing) (text v)
Con s -> (Nothing, text "Defined" <+> text "\"" <> text s <> text "\"")
$ text "Tuple" <+> bracketList (map (snd . uncurry perhaps) dpats)
List t -> let (d, pat) = findT v t
in perhaps (inc d) (text "List" <+> parens pat)
perhaps jn doc = (jn, maybe (text "_") (const doc) jn)
combine ds = let js = [ n | Just n <- ds ] in
if null js then Nothing else inc (Just (minimum js))
closest :: (Maybe Int, a) -> (Maybe Int, a) -> (Maybe Int, a)
closest a b = case (a, b) of
((Nothing, _), (Just _, _)) -> b
((Just n, _), (Just m, _)) | m >= n -> b
-- showsfn (n = index) (ns = variables) (cn = constructor body)
showsfn :: Int -> [Doc] -> Body -> Doc
let cons = constructor cn
sc = parens (text "showConstr" <+> text (show n) <+>
parens (text "toHType" <+> text "v"))
cfn [x] = parens (text "toContents" <+> x)
(text "concat" <+> bracketList (map (text "toContents" <+>) xs))
text "v@" <> mypattern cons typ ns <+> text "=" $$
nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]")
preorder :: [Body] -> [b] -> [b]
map snd . reverse . sortBy (\ (a, _) (b, _) -> compare a b)
. zip (map constructor cs)
-- parseFn (ns = variables) (cn = constructor body)
parseFn :: Bool -> t -> Body -> Doc
let cons = constructor cn
arity = length (types cn)
intro = if single then empty
else text "|" <+> text (show cons)
<+> text "`isPrefixOf` t -> interior e $"
0 -> intro <+> nest 8 (text "return" <+> text cons)
1 -> intro <+> nest 8 (text "fmap" <+> text cons <+> text "parseContents")
_ -> intro $$ nest 8 (text "return" <+> text cons
<+> fsep (replicate arity
(text "`apply` parseContents")))
instanceheader :: String -> Data -> Doc
ctx = map (\ v -> text cls <+> text v)
parenSpace = parens . hcat . sepWith space
, opt fv (\ v -> parenList (ctx v) <+> text "=>")
, opt1 (texts (tycon : fv)) parenSpace id
mypattern :: Constructor -> [a] -> [Doc] -> Doc
if null l then text c else parens (hsep (text c : take (length l) ns))
-- begin of GetRange derivation
getrangefn :: Data -> Doc
instanceSkeleton "GetRange" [] dat
$$ (if any (elem posLC . types) (body dat) then
text " getRange x = case x of"
$$ block (map makeGetPosFn $ body dat)
else text " getRange = const nullRange")
$$ text " rangeSpan x = case x of"
$$ block (map makeSpanFn $ body dat)
makeGetPosFn :: Body -> Doc
let (r, vs) = mapAccumL accFun True (types b)
if f && t == posLC then (False, p) else (f, text "_")
in ppCons' b vs <+> rArrow <+> if r then text "nullRange" else p
makeSpanFn :: Body -> Doc
let vs = varNames $ types b
in ppCons' b vs <+> rArrow
<+> if null vs then text "[]" else
text "joinRanges" <+> bracketList (map (text "rangeSpan" <+>) vs)
-- end of GetRange derivation
binaryfn :: Bool -> Data -> Doc
let dn = strippedName dat
in instanceSkeleton (if forLG then "BinaryLG" else "Binary")
$$ text (" put" ++ (if forLG then "LG" else "") ++ " xv = case xv of")
$$ block (zipWith (makePutBinary forLG moreCs) cs [0 .. ])
$$ text (" get" ++ (if forLG then "LG lg" else "") ++ " = "
++ if moreCs then "getWord8 >>= \\ tag -> case tag of" else "do")
$$ block (zipWith (makeGetBinary forLG moreCs) cs [0 .. ] ++
[u <+> rArrow <+> text "fromBinaryError"
<+> doubleQuotes (text dn) <+> u | moreCs])
makePutBinary :: Bool -> Bool -> Body -> Int -> Doc
makePutBinary forLG moreCs b i =
let vs = varNames $ types b
putComp v = text ("put" ++ if forLG then "LG" else "") <+> v
hl = if moreCs then text ("putWord8 " ++ show i) else
if null vs then text "return ()" else empty
in ppCons' b vs <+> rArrow <+> (if null vs then hl else text "do")
$$ if null vs then empty else nest 2 . vcat $ hl : map putComp vs
makeGetBinary :: Bool -> Bool -> Body -> Int -> Doc
makeGetBinary forLG moreCs b i =
let vs = varNames $ types b
v <+> lArrow <+> text ("get" ++ if forLG then "LG lg" else "")
rl = text ("return" ++ if null vs then "" else " $") <+> ppCons' b vs
in (if moreCs then text (show i) <+> rArrow else empty)
<+> (if null vs then rl else if moreCs then text "do" else empty)
$$ if null vs then empty else nest 2 . vcat $ map getComp vs ++ [rl]
-- begin of ShATermConvertible derivation
shatermfn :: Bool -> Data -> Doc
let dn = strippedName dat
in instanceSkeleton (if forLG then "ShATermLG" else "ShATermConvertible")
$$ text (" toShATerm" ++ (if forLG then "LG" else "Aux")
++ " att0 xv = case xv of")
$$ block (map (makeToShATerm forLG) cs)
$$ text (" fromShATerm" ++ (if forLG then "LG lg" else "Aux")
++ " ix att0 = case getShATerm ix att0 of")
$$ block (map (makeFromShATerm forLG) cs ++
[u <+> rArrow <+> text "fromShATermError"
<+> doubleQuotes (text dn) <+> u])
att i = text $ "att" ++ show (i :: Int)
closeBraces :: [b] -> Doc
closeBraces = hcat . map (const $ char '}')
pair :: Doc -> Doc -> Doc
pair f s = parens $ f <> comma <+> s
makeToShATerm :: Bool -> Body -> Doc
tooLong = length (constructor b) > 15
rl = text "return $ addATerm (ShAAppl" <+>
doubleQuotes (text (constructor b)) <+>
bracketList (varNames' ts) <+> text "[])" <+>
in ppCons' b vs <+> rArrow <+>
(if null vs then if tooLong then empty else rl else text "do")
$$ if null vs then if tooLong then nest 2 rl else empty
else nest 2 . vcat $ zipWith (childToShATerm forLG) vs [0 :: Int ..]
childToShATerm :: Bool -> Doc -> Int -> Doc
childToShATerm forLG v i = pair (att $ i + 1) (addPrime v) <+> lArrow
<+> text ("toShATerm" ++ if forLG then "LG'" else "'") <+> att i <+> v
makeFromShATerm :: Bool -> Body -> Doc
makeFromShATerm forLG b =
text ("case fromShATerm" ++ if forLG then "LG' lg" else "'")
<+> v <+> att i <+> text "of"
$$ text "{" <+> pair (att $ i + 1) (addPrime v) <+> rArrow
rl = pair (att $ length ts) (ppCons' b $ varNames' ts)
in text "ShAAppl" <+> doubleQuotes (text $ constructor b) <+>
bracketList vs <+> text "_" <+> rArrow
<+> (if null vs then rl else empty)
$$ if null vs then empty else
nest 2 . vcat $ zipWith childFromShATerm vs [0 :: Int ..] ++ [rl]
-- end of ATermConvertible derivation
typeablefn :: Data -> Doc
ntext str = str ++ if null vs then "" else show $ length vs
tcname = text $ "_tc" ++ dn ++ "Tc"
in tcname <+> text ":: TyCon"
$$ tcname <+> equals <+> text "mkTyCon"
<+> doubleQuotes (text $ name dat)
$$ text ("instance " ++ ntext "Typeable" ++ " " ++ dn ++ " where")
$$ block [ text (ntext "typeOf" ++ " _ = mkTyConApp")
<+> tcname <+> brackets empty]