1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
module Derive.Generate(generate) where
import Language.Haskell.Exts
import Data.DeriveDSL
import Derive.Utils
import Control.Monad
import Data.Maybe
import System.FilePath
import System.Directory
import Data.Char
import Data.List
evil = words $ "TTypeable Uniplate"
-- generate extra information for each derivation
generate :: IO ()
generate = do
xs <- getDirectoryContents "Data/Derive"
xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
lis <- mapM generateFile $ map ("Data/Derive" </>) xs
let names = map dropExtension xs
n = maximum $ map length names
writeGenerated "Data/Derive/All.hs" $
["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++
["derivations :: [Derivation]"
,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]
writeGenerated "derive.htm" $ ["-->"] ++ lis ++ ["<!--"]
writeGenerated "derive.cabal" $ map (" Data.Derive."++) names
-- return the Documentation string
generateFile :: FilePath -> IO String
generateFile file = do
let name = takeBaseName file
putStrLn $ "Generating " ++ name
src <- readSrc file
when (isJust $ srcExample src) $ do
let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $
deriveDSL $ fromJust $ srcExample src
writeGenerated file $
[""
,"import Data.Derive.DSL.DSL"
,"import Data.Derive.Internal.Derivation"
,""
,"make" ++ name ++ " :: Derivation"
] ++ (if srcCustom src then
["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]
else
["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name
,""
,"dsl" ++ name ++ " ="
]) ++
map (replicate 4 ' ' ++) (wrap 66 $ show dsl)
let inst = dynamicDSL dsl
instFile = takeDirectory file </> "Instance" </> name <.> "hs"
b <- doesFileExist instFile
if not (srcCustom src) && isJust inst then do
writeGenerated instFile $
["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] ++
["","module Data.Derive.Instance." ++ name ++ " where",""] ++
(map prettyPrint $ srcImportStd src) ++
["import Data.Derive.Internal.Instance",""] ++
(map prettyPrint $ fromJust inst) ++ [""]
else when b $
error $ "Previously generated dynamic instance can not be regenerated, " ++ name
let imp = listToMaybe $ srcImport src
return $ concat $
["<li>"
,"<b><a href='" ++ instUrl name imp ++ "'>" ++ name ++ "</a></b>"] ++
[" - from the library <a href='" ++ pkgUrl pkg ++ "'>" ++ pkg ++ "</a>" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp] ++
["</li>"]
pkgUrl x = "http://hackage.haskell.org/package/" ++ x
instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"
instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam
where
(a,b) = break (== '-') $ fromMaybe "base" $ importPkg x
pkgName = a
pkgVersion = if null b then "latest" else tail b
modu = reps '.' '-' $ prettyPrint $ importModule x
nam = case importSpecs x of Just (False,IAbs y:_) -> prettyPrint y ; _ -> name
wrap :: Int -> String -> [String]
wrap n = f . lexemes
where
f [] = []
f (x:xs) = [reverse $ dropWhile isSpace $ reverse $ concat $ x:a] ++ f (dropWhile (all isSpace) b)
where (a,b) = thisLine (n - length x) xs
thisLine i [] = ([], [])
thisLine i (x:xs) | j > i = ([], x:xs)
| otherwise = (x:a, b)
where j = length x
(a,b) = thisLine (i - j) xs
lexemes :: String -> [String]
lexemes [] = []
lexemes x = a : lexemes b
where (a,b) = lexeme x
lexeme :: String -> (String, String)
lexeme xs@(x:_) | isAlpha x = span isAlpha xs
lexeme ('\"':xs) = let (a,b) = f xs in ('\"':a,b)
where f ('\\':x:xs) = let (a,b) = f xs in ('\\':x:a,b)
f ('\"':xs) = ("\"",xs)
f (x:xs) = let (a,b) = f xs in (x:a,b)
f [] = ([],[])
lexeme (x:xs) = ([x], xs)
|
