module Code.Build where
import Data.List
newtype Code = Code { unCode :: [String] }
showCode :: Code -> String
showCode = intercalate "\n" . unCode
class Codeable a where
code :: a -> Code
instance Codeable Code where
code = id
instance Codeable String where
code = Code . (:[])
instance Codeable a => Codeable (Maybe a) where
code = maybe noCode code
instance Show a => Codeable a where
code = Code . (:[]) . show
class CodeList a where
codeList :: a -> [Code]
instance Codeable a => CodeList a where
codeList = (:[]) . code
instance Codeable a => CodeList [a] where
codeList = map code
noCode :: Code
noCode = Code []
line :: Code
line = Code [""]
isNull :: Codeable a => a -> Bool
isNull = null . unCode . code
numLines :: CodeList a => a -> Int
numLines = length . unCode . mkStack . codeList
singleLine :: CodeList a => a -> Bool
singleLine = (==1) . numLines
indent :: Codeable a => Int -> a -> Code
indent n = Code . map (replicate n ' ' ++) . unCode . code
surround :: Codeable a => String -> String -> a -> Code
surround l r a = l <+> a <+> r
parenthesis :: Codeable a => a -> Code
parenthesis = surround "(" ")"
accolades :: Codeable a => a -> Code
accolades = surround "{" "}"
square :: Codeable a => a -> Code
square = surround "[" "]"
align :: Codeable a => a -> Code
align v = Code . map addWhite . unCode . code $ v
where addWhite l = l ++ replicate (codeWidth v length l) ' '
codeWidth :: Codeable a => a -> Int
codeWidth = foldr max 0 . map length . unCode . code
codeLines :: Codeable a => a -> [Code]
codeLines = map (Code . (:[])) . unCode . code
many :: Codeable a => a -> Code
many = Code . concat . repeat . unCode . code
mkSequence :: Codeable a => [a] -> Code
mkSequence = foldl (<+>) noCode . map code
mkStack :: Codeable a => [a] -> Code
mkStack = foldl (<->) noCode . map code
interleave :: (Codeable a, CodeList l) => a -> l -> Code
interleave c l =
case codeList l of
[] -> noCode
[x] -> x
(x: xs) -> x <+> code c <+> interleave c xs
infixl 4 <+>
infixl 4 <++>
infixl 4 <+|
infixl 3 |>+<|
infixl 3 |><|
infixl 3 ><
infixl 3 |><
infixl 3 ><|
infixl 2 <->
(|><|) :: (Codeable a, Codeable b) => a -> b -> Code
a |><| b = Code $ zipWith (++) ca cb
where ca = unCode . code $ a
cb = unCode . code $ b
(><) :: (Codeable a, Codeable b) => a -> b -> Code
a >< b = a <-> mkStack (replicate ((numLines (code b) numLines (code a)) `max` 0) line) |><| b <-> mkStack (replicate ((numLines (code a) numLines (code b)) `max` 0) line)
(|><) :: (Codeable a, Codeable b) => a -> b -> Code
a |>< b = a <-> mkStack (replicate ((numLines (code b) numLines (code a)) `max` 0) line) |><| b
(><|) :: (Codeable a, Codeable b) => a -> b -> Code
a ><| b = a |><| b <-> mkStack (replicate ((numLines (code a) numLines (code b)) `max` 0) line)
(<+>) :: (Codeable a, Codeable b) => a -> b -> Code
a <+> b =
case ca of
[] -> code b
ls -> case cb of
[] -> code a
(bl: bls) -> Code $ init ls ++ [last ls ++ bl] ++ bls
where ca = unCode . code $ a
cb = unCode . code $ b
(<++>) :: (Codeable a, Codeable b) => a -> b -> Code
a <++> b
| empty a = code b
| empty b = code a
| otherwise = a <+> " " <+> b
where
empty x = all (== "") (unCode (code x))
(<+|) :: (Codeable a, Codeable b) => a -> b -> Code
a <+| b =
case ca of
[] -> code b
ls -> case cb of
[] -> code a
(bl: bls) -> Code $ init ls ++ [last ls ++ bl] ++ map (replicate (length $ last ls) ' ' ++) bls
where ca = unCode . code $ a
cb = unCode . code $ b
(|>+<|) :: (Codeable a, CodeList b) => a -> b -> Code
a |>+<| b = mkStack $ zipWith (<+|) (codeLines a) (codeList b)
(<->) :: (Codeable a, Codeable b) => a -> b -> Code
a <-> b = Code $ (unCode $ code a) ++ (unCode $ code b)