HSE analysis of atoms

hse-atom.hs

{-# LANGUAGE ScopedTypeVariables #-}

-- Note that 1 vs -1  is one of the few things that matters!!!

import Language.Haskell.Exts
import Language.Haskell.Exts.Util
import Data.Data
import Control.Monad
import Data.List

main = do
    let dtype = dataTypeOf (undefined :: Exp ())
    let ctors = dataTypeConstrs dtype
    let exps = map (fromConstrB mkDefault) ctors :: [Exp ()]
    let (good, bad) = partition safe exps
    putStrLn $ "BROKEN = " ++ intercalate "; " (map disp bad)
    let (atom, comp) = partition checkAtom good
    putStrLn $ "ATOM = " ++ intercalate "; " [disp x | x <- atom, not $ isAtom x]
    putStrLn $ "COMPOSITE = " ++ intercalate "; " [disp x | x <- comp, isAtom x]

    let dtype = dataTypeOf (undefined :: Pat ())
    let ctors = dataTypeConstrs dtype
    let exps = map (fromConstrB mkDefault) ctors :: [Pat ()]
    let (good, bad) = partition safeP exps
    putStrLn $ "BROKEN = " ++ intercalate "; " (map disp bad)
    let (atom, comp) = partition checkAtomP good
    putStrLn $ "ATOM = " ++ intercalate "; " [disp x | x <- atom, not $ isAtom x]
    putStrLn $ "COMPOSITE = " ++ intercalate "; " [disp x | x <- comp, isAtom x]


disp x = ctor x ++ " " ++ prettyPrint x

ctor x = head . words . show $ x

modes = defaultParseMode{extensions = map EnableExtension [minBound .. maxBound]}

checkAtom x = safe (App () x x)
checkAtomP x = safeP (PApp () (UnQual () $ Ident () "Foo") [x,x])

safe x = case parseExpWithMode modes (prettyPrint x) of
    ParseOk y -> x == fmap (const ()) y
    _ -> False

safeP x = case parsePatWithMode modes (prettyPrint x) of
    ParseOk y -> x == fmap (const ()) y
    _ -> False

mkDefault :: forall a . Data a => a
mkDefault
    | Just x <- cast () = x
    | Just x <- cast "foo" = x
    | Just x <- cast qname = x
    | Just x <- cast name = x
    | Just x <- cast $ Signless () = x
    | Just x <- cast (1 :: Integer) = x
    | Just x <- cast $ IPDup () "foo" = x
    | Just x <- cast $ Int () 1 "1" = x
    | Just x <- cast exp = x
    | Just x <- cast [exp, exp] = x
    | Just x <- cast [RPPat () pat] = x
    | Just x <- cast [Just exp, Nothing] = x
    | Just x <- cast [FieldUpdate () qname exp] = x
    | Just x <- cast [PFieldPat () qname pat] = x
    | Just x <- cast [QualStmt () stmt] = x
    | Just x <- cast qop = x
    | Just x <- cast Boxed = x
    | Just x <- cast [pat] = x
    | Just x <- cast $ Just pat = x
    | Just x <- cast typ = x
    | Just x <- cast [[QualStmt () stmt]] = x
    | Just x <- cast $ BDecls () [] = x
    | Just x <- cast [GuardedRhs () [] exp] = x
    | Just x <- cast [Alt () pat rhs Nothing] = x
    | Just x <- cast [stmt] = x
    | Just x <- cast $ ExpBracket () exp = x
    | Just x <- cast $ IdSplice () "foo" = x
    | Just x <- cast xname = x
    | Just x <- cast $ Just exp = x
    | Just x <- cast pat = x
    | Just x <- cast (1 :: Int, 1 :: Int) = x
    | Just x <- cast [XAttr () xname exp] = x
    | Just x <- cast [PXAttr () xname pat] = x
    | otherwise = error $ show (typeOf (undefined :: a))
    where
        qname = UnQual () name
        name = Ident () "foo"
        exp = Var () qname
        qop = QVarOp () $ UnQual () $ Ident () "foo"
        pat = PVar () name
        rhs = UnGuardedRhs () exp
        typ = TyVar () name
        stmt = Qualifier () exp
        xname = XName () "foo"